site/cgi-bin/modules/BSE/Edit/Product.pm

   1 package BSE::Edit::Product;
   2 use strict;
   3 use base 'BSE::Edit::Article';
   4 use BSE::TB::Products;
   5 use HTML::Entities;
   6 use BSE::Template;
   7 use BSE::Util::Iterate;
   8 use BSE::Util::HTML;
   9 use BSE::CfgInfo 'product_options';
  10 use BSE::Util::Tags qw(tag_hash tag_article);
  11 use constant PRODUCT_CUSTOM_FIELDS_CFG => "product custom fields";
  12
  13 our $VERSION = "1.016";
  14
  15 =head1 NAME
  16
  17 BSE::Edit::Product - tags and actions for editing BSE products
  18
  19 =head1 SYNOPSIS
  20
  21   http://www.example.com/cgi-bin/admin/add.pl ...
  22
  23 =head1 DESCRIPTION
  24
  25 Article editor subclass for editing Products.
  26
  27 =cut
  28
  29 my %money_fields =
  30   (
  31    retailPrice => "Retail price",
  32    wholesalePrice => "Wholesale price",
  33    gst => "GST",
  34   );
  35
  36 sub generator { 'BSE::Generate::Product' }
  37
  38 sub _make_dummy_article {
  39   my ($self, $article) = @_;
  40
  41   require BSE::DummyProduct;
  42   return bless $article, "BSE::DummyProduct";
  43 }
  44
  45 sub base_template_dirs {
  46   return ( "products" );
  47 }
  48
  49 sub extra_templates {
  50   my ($self, $article) = @_;
  51
  52   my @extras = $self->SUPER::extra_templates($article);
  53   push @extras, 'shopitem.tmpl'
  54     if grep -f "$_/shopitem.tmpl",
  55       BSE::Template->template_dirs($self->{cfg});
  56
  57   my $extras = $self->{cfg}->entry('products', 'extra_templates');
  58   push @extras, grep /\.(tmpl|html)$/i, split /,/, $extras
  59     if $extras;
  60
  61   return @extras;
  62 }
  63
  64 sub hash_tag {
  65   my ($article, $arg) = @_;
  66
  67   my $value = $article->{$arg};
  68   defined $value or $value = '';
  69   if ($value =~ /\cJ/ && $value =~ /\cM/) {
  70     $value =~ tr/\cM//d;
  71   }
  72
  73   return encode_entities($value);
  74 }
  75
  76 sub iter_subs {
  77   require BSE::TB::Subscriptions;
  78   BSE::TB::Subscriptions->all;
  79 }
  80
  81 sub iter_option_values {
  82   my ($self, $rcurrent_option, $args) = @_;
  83
  84   $$rcurrent_option
  85     or return;
  86
  87   return $$rcurrent_option->values;
  88 }
  89
  90 sub tag_hash_mbcs {
  91   my ($object, $args) = @_;
  92
  93   my $value = $object->{$args};
  94   defined $value or $value = '';
  95   if ($value =~ /\cJ/ && $value =~ /\cM/) {
  96     $value =~ tr/\cM//d;
  97   }
  98   escape_html($value, '<>&"');
  99 }
 100
 101 sub tag_dboptionvalue_move {
 102   my ($self, $req, $article, $rvalues, $rindex, $args) = @_;
 103
 104   $$rindex >= 0 && $$rindex < @$rvalues
 105     or return "** dboptionvalue_move only in dboption_values iterator **";
 106
 107   my $my_id = $rvalues->[$$rindex]{id};
 108   my $base_url = "$ENV{SCRIPT_NAME}?id=$article->{id}&value_id=$my_id&_csrfp=".$req->get_csrf_token("admin_move_option_value") . "&";
 109
 110   my $t = $req->cgi->param('_t');
 111   $t && $t =~ /^\w+$/
 112     and $base_url .= "_t=$t&";
 113
 114   my $up_url = '';
 115   if ($$rindex > 0) {
 116     $up_url = $base_url . "a_option_value_moveup=1";
 117   }
 118   my $down_url = '';
 119   if ($$rindex < $#$rvalues) {
 120     $down_url = $base_url . "a_option_value_movedown=1";
 121   }
 122
 123   my $refresh = $self->refresh_url($article, $req->cgi);
 124
 125   require BSE::Arrows;
 126   return BSE::Arrows::make_arrows($req->cfg, $down_url, $up_url, $refresh, $args, id => $my_id, id_prefix => "prodoptvaluemove");
 127 }
 128
 129 sub tag_dboption_move {
 130   my ($self, $req, $article, $roptions, $rindex, $args) = @_;
 131
 132   $$rindex >= 0 && $$rindex < @$roptions
 133     or return "** dboption_move only in dboptions iterator **";
 134
 135   my $my_id = $roptions->[$$rindex]{id};
 136   my $base_url = "$ENV{SCRIPT_NAME}?id=$article->{id}&option_id=$my_id&_csrfp=".$req->get_csrf_token("admin_move_option") . "&";
 137
 138   my $t = $req->cgi->param('_t');
 139   $t && $t =~ /^\w+$/
 140     and $base_url .= "_t=$t&";
 141
 142   my $up_url = '';
 143   if ($$rindex > 0) {
 144     $up_url = $base_url . "a_option_moveup=1";
 145   }
 146   my $down_url = '';
 147   if ($$rindex < $#$roptions) {
 148     $down_url = $base_url . "a_option_movedown=1";
 149   }
 150
 151   my $refresh = $self->refresh_url($article, $req->cgi);
 152
 153   require BSE::Arrows;
 154   return BSE::Arrows::make_arrows($req->cfg, $down_url, $up_url, $refresh, $args, id => $my_id, id_prefix => "prodoptmove");
 155 }
 156
 157 sub tag_tier_price {
 158   my ($self, $rtier, $rprices, $product) = @_;
 159
 160   unless ($rprices->{loaded}) {
 161     %$rprices = map { $_->tier_id => $_ } $product->prices
 162       if $product->{id};
 163     $rprices->{loaded} = 1;
 164   }
 165
 166   $$rtier or return '** no current tier **';
 167
 168   exists $rprices->{$$rtier->id}
 169     or return '';
 170
 171   return $rprices->{$$rtier->id}->retailPrice;
 172 }
 173
 174 sub save_more {
 175   my ($self, $req, $article, $data) = @_;
 176
 177   $self->_save_price_tiers($req, $article, $data);
 178   $self->SUPER::save_more($req, $article, $data);
 179 }
 180
 181 sub save_new_more {
 182   my ($self, $req, $article, $data) = @_;
 183
 184   $self->_save_price_tiers($req, $article, $data);
 185   $self->SUPER::save_new_more($req, $article, $data);
 186 }
 187
 188 sub _save_price_tiers {
 189   my ($self, $req, $article, $data) = @_;
 190
 191   $data->{save_pricing_tiers}
 192     or return;
 193
 194   $req->user_can('edit_field_edit_retailPrice', $article)
 195     or return;
 196
 197   my @tiers = BSE::TB::Products->pricing_tiers;
 198   my %prices;
 199   for my $tier (@tiers) {
 200     my $key = "tier_price_" . $tier->id;
 201     if (exists $data->{$key} && $data->{$key} =~ /\S/) {
 202       $prices{$tier->id} = $data->{$key} * 100;
 203     }
 204   }
 205   $article->set_prices(\%prices);
 206 }
 207
 208 sub save_columns {
 209   my ($self, $table_object) = @_;
 210
 211   my @cols = $self->SUPER::save_columns($table_object);
 212   my @tiers = BSE::TB::Products->pricing_tiers;
 213   if (@tiers) {
 214     push @cols, "save_pricing_tiers";
 215     push @cols, map { "tier_price_" . $_->id } @tiers;
 216   }
 217
 218   return @cols;
 219 }
 220
 221 sub iter_dboptions {
 222   my ($self, $article) = @_;
 223
 224   $article->{id}
 225     or return;
 226
 227   return $article->db_options;
 228 }
 229
 230 =head1 Edit tags
 231
 232 These a tags available on admin/edit_* pages specific to products.
 233
 234 =over
 235
 236 =item *
 237
 238 product I<field> - display the given field from the product being edited.
 239
 240 =item *
 241
 242 iterator begin dboptions ... dboption I<field> ... iterator end dboptions
 243
 244 - iterate over the existing database stored options for the product
 245
 246 =item *
 247
 248 dboption_move - display arrows to move the current dboption.  The span
 249 for the arrows is given an id of "prodoptmoveI<option-id>" by default.
 250
 251 =item *
 252
 253 iterator begin dboptionvalues ... dboptionvalue I<field> ... iterator end dboptionvalues
 254
 255 - iterate over the values for the current dboption
 256
 257 =item *
 258
 259 dboptionvalue_move - display arrows to move the current dboption.  The
 260 span for the arrows is given an id of "prodoptvaluemoveI<value-id>"
 261 by default.
 262
 263 =item *
 264
 265 dboptionsjson - returns the product options as JSON.
 266
 267 =item *
 268
 269 iterator begin price_tiers ... price_tier I<field> ... iterator end price_tiers
 270
 271 Iterate over the configured price tiers.
 272
 273 =item *
 274
 275 tier_price
 276
 277 Return the price at the current price_tier.  Returns an empty string
 278 if there's no price at this tier.
 279
 280 =back
 281
 282 =cut
 283
 284 sub low_edit_tags {
 285   my ($self, $acts, $req, $article, $articles, $msg, $errors) = @_;
 286
 287   my $product_opts = product_options($req->cfg);
 288
 289   my $cfg = $req->cfg;
 290   my $mbcs = $cfg->entry('html', 'mbcs', 0);
 291   my $tag_hash = $mbcs ? \&tag_hash_mbcs : \&hash_tag;
 292   my $current_option;
 293   my @dboptions;
 294   my $dboption_index;
 295   my @dboption_values;
 296   my $dboption_value_index;
 297   my $current_option_value;
 298   my $it = BSE::Util::Iterate->new;
 299   my @tiers;
 300   my $price_tier;
 301   my %prices;
 302   $req->set_variable(product => $article);
 303   return
 304     (
 305      product => [ \&tag_article, $article, $cfg ],
 306      $self->SUPER::low_edit_tags($acts, $req, $article, $articles, $msg,
 307                                 $errors),
 308      alloptions => join(",", sort keys %$product_opts),
 309      $it->make_iterator
 310      ([ \&iter_subs, $req ], 'subscription', 'subscriptions'),
 311      $it->make
 312      (
 313       single => "dboption",
 314       plural => "dboptions",
 315       store => \$current_option,
 316       data => \@dboptions,
 317       index => \$dboption_index,
 318       code => [ iter_dboptions => $self, $article ],
 319      ),
 320      dboption_move =>
 321      [
 322       tag_dboption_move =>
 323       $self, $req, $article, \@dboptions, \$dboption_index
 324      ],
 325      $it->make
 326      (
 327       single => "dboptionvalue",
 328       plural => "dboptionvalues",
 329       data => \@dboption_values,
 330       index => \$dboption_value_index,
 331       store => \$current_option_value,
 332       code => [ iter_option_values => $self, \$current_option ],
 333       nocache => 1,
 334      ),
 335      dboptionsjson => [ tag_dboptionsjson => $self, $article ],
 336      dboptionvalue_move =>
 337      [
 338       tag_dboptionvalue_move =>
 339       $self, $req, $article, \@dboption_values, \$dboption_value_index
 340      ],
 341      $it->make
 342      (
 343       single => "price_tier",
 344       plural => "price_tiers",
 345       code => [ pricing_tiers => "BSE::TB::Products" ],
 346       data => \@tiers,
 347       store => \$price_tier,
 348      ),
 349      tier_price => [ tag_tier_price => $self, \$price_tier, \%prices, $article ],
 350     );
 351 }
 352
 353 sub edit_template {
 354   my ($self, $article, $cgi) = @_;
 355
 356   my $base = 'product';
 357   my $t = $cgi->param('_t');
 358   if ($t && $t =~ /^\w+$/) {
 359     $base = $t;
 360   }
 361   return $self->{cfg}->entry('admin templates', $base,
 362                              "admin/edit_$base");
 363 }
 364
 365 sub add_template {
 366   my ($self, $article, $cgi) = @_;
 367
 368   return $self->{cfg}->entry('admin templates', 'add_product',
 369                              'admin/edit_product');
 370 }
 371
 372 sub validate_parent {
 373   my ($self, $data, $articles, $parent, $rmsg) = @_;
 374
 375   my $shopid = $self->{cfg}->entryErr('articles', 'shop');
 376   unless ($parent &&
 377           $parent->{generator} eq 'BSE::Generate::Catalog') {
 378     $$rmsg = "Products must be in a catalog (not $parent->{generator})";
 379     return;
 380   }
 381
 382   return $self->SUPER::validate_parent($data, $articles, $parent, $rmsg);
 383 }
 384
 385 sub _validate_common {
 386   my ($self, $data, $articles, $errors) = @_;
 387
 388   $self->SUPER::_validate_common($data, $articles, $errors);
 389
 390   for my $col (keys %money_fields) {
 391     my $value = $data->{$col};
 392     defined $value or next;
 393     unless ($value =~ /^\d+(\.\d{1,2})?\s*/) {
 394       $errors->{$col} = "$money_fields{$col} invalid";
 395     }
 396   }
 397
 398   if (defined $data->{options}) {
 399     my $avail_options = product_options($self->{cfg});
 400
 401     my @bad_opts = grep !$avail_options->{$_},
 402       split /,/, $data->{options};
 403     if (@bad_opts) {
 404       $errors->{options} = "Bad product options '". join(",", @bad_opts)."' entered";
 405     }
 406   }
 407
 408   my @subs;
 409   for my $sub_field (qw(subscription_id subscription_required)) {
 410     my $value = $data->{$sub_field};
 411     defined $value or next;
 412     if ($value ne '-1') {
 413       require BSE::TB::Subscriptions;
 414       @subs = BSE::TB::Subscriptions->all unless @subs;
 415       unless (grep $_->{subscription_id} == $value, @subs) {
 416         $errors->{$sub_field} = "Invalid $sub_field value";
 417       }
 418     }
 419   }
 420   if (defined $data->{subscription_period}) {
 421     my $sub = $data->{subscription_id};
 422     if ($data->{subscription_period} !~ /^\d+$/) {
 423       $errors->{subscription_period} = "Invalid subscription period, it must be the number of months to subscribe";
 424     }
 425     elsif ($sub != -1 && $data->{subscription_period} < 1) {
 426       $errors->{subscription_period} = "Subscription period must be 1 or more when a subscription is selected";
 427     }
 428   }
 429   if (defined $data->{subscription_usage}) {
 430     unless ($data->{subscription_usage} =~ /^[123]$/) {
 431       $errors->{subscription_usage} = "Invalid subscription usage";
 432     }
 433   }
 434
 435   if ($data->{save_pricing_tiers}) {
 436     my @tiers = BSE::TB::Products->pricing_tiers;
 437     for my $tier (@tiers) {
 438       my $key = "tier_price_" . $tier->id;
 439       my $value = $data->{$key};
 440       defined $value or next;
 441       if ($value =~ /\S/ && $value !~ /^\d+(\.\d{1,2})?\s*/) {
 442         $errors->{$key} = 'Pricing tier "' . $tier->description . '" price invalid';
 443       }
 444     }
 445   }
 446
 447   return !keys %$errors;
 448 }
 449
 450 sub validate {
 451   my ($self, $data, $articles, $errors) = @_;
 452
 453   my $ok = $self->SUPER::validate($data, $articles, $errors);
 454   $self->_validate_common($data, $articles, $errors);
 455
 456   for my $field (qw(title)) {
 457     unless ($data->{$field} =~ /\S/) {
 458       $errors->{$field} = "No $field entered";
 459     }
 460   }
 461
 462   return $ok && !keys %$errors;
 463 }
 464
 465 sub validate_old {
 466   my ($self, $article, $data, $articles, $errors) = @_;
 467
 468   $self->SUPER::validate_old($article, $data, $articles, $errors)
 469     or return;
 470
 471   return !keys %$errors;
 472 }
 473
 474 sub possible_parents {
 475   my ($self, $article, $articles) = @_;
 476
 477   my %labels;
 478   my @values;
 479
 480   my $shopid = $self->{cfg}->entryErr('articles', 'shop');
 481   # the parents of a catalog can be other catalogs or the shop
 482   my $shop = $articles->getByPkey($shopid);
 483   my @work = [ $shopid, $shop->{title} ];
 484   while (@work) {
 485     my ($id, $title) = @{pop @work};
 486     push(@values, $id);
 487     $labels{$id} = $title;
 488     push @work, map [ $_->{id}, $title.' / '.$_->{title} ],
 489     sort { $b->{displayOrder} <=> $a->{displayOrder} }
 490       grep $_->{generator} eq 'BSE::Generate::Catalog',
 491       $articles->getBy(parentid=>$id);
 492   }
 493   unless ($shop->{generator} eq 'BSE::Generate::Catalog') {
 494     shift @values;
 495     delete $labels{$shopid};
 496   }
 497   return (\@values, \%labels);
 498 }
 499
 500 sub table_object {
 501   my ($self, $articles) = @_;
 502
 503   'BSE::TB::Products';
 504 }
 505
 506 sub get_article {
 507   my ($self, $articles, $article) = @_;
 508
 509   return BSE::TB::Products->getByPkey($article->{id});
 510 }
 511
 512 sub default_link_path {
 513   my ($self, $article) = @_;
 514
 515   $self->{cfg}->entry('uri', 'shop', '/shop');
 516 }
 517
 518 sub make_link {
 519   my ($self, $article) = @_;
 520
 521   $article->is_linked
 522     or return "";
 523
 524 # Modified by adrian
 525   my $urlbase = '';
 526   if ($self->{cfg}->entry('shop', 'secureurl_articles', 1)) {
 527     $urlbase = $self->{cfg}->entryVar('site', 'secureurl');
 528   }
 529 # end adrian
 530
 531   if ($article->is_dynamic) {
 532     (my $extra = $article->title) =~ tr/A-Za-z0-9/-/sc;
 533     return "$urlbase/cgi-bin/page.pl?page=$article->{id}&title=".escape_uri($extra);
 534   }
 535
 536   my $shop_uri = $self->link_path($article);
 537   return $urlbase.$shop_uri."/shop$article->{id}.html";
 538 }
 539
 540 sub _fill_product_data {
 541   my ($self, $req, $data, $src) = @_;
 542
 543   for my $money_col (qw(retailPrice wholesalePrice gst)) {
 544     if (exists $src->{$money_col}) {
 545       if ($src->{$money_col} =~ /^\d+(\.\d\d)?\s*/) {
 546         $data->{$money_col} = 100 * $src->{$money_col};
 547       }
 548       else {
 549         $data->{$money_col} = 0;
 550       }
 551     }
 552   }
 553   if (exists $src->{leadTime}) {
 554     $src->{leadTime} =~ /^\d+\s*$/
 555       or $src->{leadTime} = 0;
 556     $data->{leadTime} = $src->{leadTime};
 557   }
 558   if (exists $src->{description} && length $src->{description}) {
 559     if ($data->{id}) {
 560       if ($req->user_can('edit_field_edit_description', $data)) {
 561         $data->{description} = $src->{description};
 562       }
 563     }
 564   }
 565   if (exists $src->{product_code} && length $src->{product_code}) {
 566     if ($data->{id}) {
 567       if ($req->user_can('edit_field_edit_product_code', $data)) {
 568         $data->{product_code} = $src->{product_code};
 569       }
 570     }
 571   }
 572   for my $field (qw(options subscription_id subscription_period
 573                     subscription_usage subscription_required
 574                     weight length width height)) {
 575     if (exists $src->{$field}) {
 576       $data->{$field} = $src->{$field};
 577     }
 578     elsif ($data == $src) {
 579       # use the default
 580       $data->{$field} = $self->default_value($req, $data, $field);
 581     }
 582   }
 583 }
 584
 585 sub fill_new_data {
 586   my ($self, $req, $data, $articles) = @_;
 587
 588   $self->_fill_product_data($req, $data, $data);
 589
 590   return $self->SUPER::fill_new_data($req, $data, $articles);
 591 }
 592
 593 sub fill_old_data {
 594   my ($self, $req, $article, $src) = @_;
 595
 596   $self->_fill_product_data($req, $article, $src);
 597
 598   return $self->SUPER::fill_old_data($req, $article, $src);
 599 }
 600
 601 sub default_template {
 602   my ($self, $article, $cfg, $templates) = @_;
 603
 604   my $template = $cfg->entry('products', 'template');
 605   return $template
 606     if $template && grep $_ eq $template, @$templates;
 607
 608   return $self->SUPER::default_template($article, $cfg, $templates);
 609 }
 610
 611 sub flag_sections {
 612   my ($self) = @_;
 613
 614   return ( 'product flags', $self->SUPER::flag_sections );
 615 }
 616
 617 sub shop_article { 1 }
 618
 619 my %defaults =
 620   (
 621    options => '',
 622    description => '',
 623    subscription_id => -1,
 624    subscription_required => -1,
 625    subscription_period => 1,
 626    subscription_usage => 3,
 627    leadTime => 0,
 628    retailPrice => 0,
 629    wholesalePrice => 0,
 630    gst => 0,
 631    product_code => '',
 632    weight => 0,
 633    length => 0,
 634    height => 0,
 635    width => 0,
 636   );
 637
 638 sub default_value {
 639   my ($self, $req, $article, $col) = @_;
 640
 641   my $value = $self->SUPER::default_value($req, $article, $col);
 642   defined $value and return $value;
 643
 644   exists $defaults{$col} and return $defaults{$col};
 645
 646   return;
 647 }
 648
 649 sub type_default_value {
 650   my ($self, $req, $col) = @_;
 651
 652   my $value = $req->cfg->entry('product defaults', $col);
 653   defined $value and return $value;
 654
 655   return $self->SUPER::type_default_value($req, $col);
 656 }
 657
 658 my %option_fields =
 659   (
 660    name =>
 661    {
 662     description => "Option name",
 663     required => 1,
 664     rules => "dh_one_line",
 665     maxlength => 255,
 666    },
 667    value1 =>
 668    {
 669     description => "Value 1",
 670     rules => "dh_one_line",
 671     maxlength => 255,
 672    },
 673   );
 674
 675 =head1 Targets
 676
 677 Actions you can request from add.pl for products.
 678
 679 =over
 680
 681 =item a_add_option
 682
 683 Add a new product option.
 684
 685 On failure perform a service error.
 686
 687 Requires _csrfp for admin_add_option
 688
 689 For Ajax requests (or with a _ parameter) returns JSON like:
 690
 691   {
 692    success: 1,
 693    option: { <option data> },
 694    values: [ { value data }, { value data }, ... ]
 695   }
 696
 697 Parameters:
 698
 699 =over
 700
 701 =item *
 702
 703 id - Article id
 704
 705 =item *
 706
 707 name - Name of the option (required)
 708
 709 =item *
 710
 711 value1 .. value5 - if any of these are non-blank they are added to the
 712 option as values.
 713
 714 =back
 715
 716 Permission required: bse_edit_prodopt_add
 717
 718 =cut
 719
 720 sub req_add_option {
 721   my ($self, $req, $article, $articles, $msg, $errors) = @_;
 722
 723   $req->check_csrf('admin_add_option')
 724     or return $self->csrf_error($req, $article, "admin_add_option", "Add Product Option");
 725
 726   $req->user_can(bse_edit_prodopt_add => $article)
 727     or return $self->_service_error($req, $article, $articles, "Insufficient product access to add options");
 728
 729   my %errors;
 730   my %work_option_fields = \%option_fields;
 731   for my $field (grep /^value[1-9][0-9]*$/, $req->cgi->param) {
 732     my ($index) = ( $field =~ /([1-9][0-9]*)$/);
 733     $work_option_fields{$field} =
 734       {
 735         description => "Value $index",
 736         rules => "dh_one_line",
 737         maxlength => 255,
 738       };
 739   }
 740   $req->validate(fields => \%work_option_fields,
 741                  errors => \%errors);
 742   keys %errors
 743     and return $self->_service_error($req, $article, $articles, undef,
 744                                      \%errors);
 745
 746   my $cgi = $req->cgi;
 747   require BSE::TB::ProductOptions;
 748   require BSE::TB::ProductOptionValues;
 749   my $option = BSE::TB::ProductOptions->make
 750     (
 751      product_id => $article->{id},
 752      name => scalar($cgi->param('name')),
 753      display_order => time,
 754     );
 755
 756   my $order = time;
 757   my @values;
 758   my %value_keys;
 759   for my $value_key (sort grep /^value/, keys %work_option_fields) {
 760     my ($value) = $cgi->param($value_key);
 761     if (defined $value && $value =~ /\S/) {
 762       my $entry = BSE::TB::ProductOptionValues->make
 763         (
 764          product_option_id => $option->{id},
 765          value => $value,
 766          display_order => $order,
 767         );
 768       push @values, $entry;
 769       $value_keys{$value_key} = $entry;
 770       ++$order;
 771     }
 772   }
 773   my $def = $cgi->param("default");
 774   if ($def && $value_keys{$def}) {
 775     $option->set_default_value($value_keys{$def}->id);
 776     $option->save;
 777   }
 778
 779   $req->is_ajax
 780     and return $req->json_content
 781       (
 782        success => 1,
 783        option => $option->data_only,
 784        values => [ map $_->data_only, @values ]
 785       );
 786
 787   return $self->refresh($article, $cgi, undef, "Option added");
 788 }
 789
 790 my %option_id =
 791   (
 792    option_id =>
 793    {
 794     rules => "required;positiveint",
 795    },
 796   );
 797
 798 sub _get_option {
 799   my ($self, $req, $article, $errors) = @_;
 800
 801   my $option;
 802   my $cgi = $req->cgi;
 803   $req->validate(fields => \%option_id,
 804                  errors => $errors);
 805   my @option_ids = $cgi->param("option_id");
 806   unless ($errors->{option_id}) {
 807     @option_ids == 1
 808       or $errors->{option_id} = "This request accepts only one option_id";
 809   }
 810   unless ($errors->{option_id}) {
 811     require BSE::TB::ProductOptions;
 812     $option = BSE::TB::ProductOptions->getByPkey($cgi->param("option_id"));
 813     $option
 814       or $errors->{option_id} = "Unknown option id";
 815   }
 816   unless ($errors->{option_id}) {
 817     $option->{product_id} = $article->{id}
 818       or $errors->{option_id} = "Option doesn't belong to this product";
 819   }
 820   $errors->{option_id}
 821     and return;
 822
 823   return $option;
 824 }
 825
 826 sub _common_option {
 827   my ($self, $template, $req, $article, $articles, $msg, $errors) = @_;
 828
 829   my %errors;
 830   my $option = $self->_get_option($req, $article, \%errors);
 831   keys %errors
 832     and return $self->_service_error($req, $article, $articles, undef, \%errors);
 833
 834   $req->set_variable(option => $option);
 835   $req->messages($errors);
 836   my $it = BSE::Util::Iterate->new;
 837   my %acts;
 838   %acts =
 839     (
 840      $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors),
 841      option => [ \&tag_hash, $option ],
 842      $it->make
 843      (
 844       single => "dboptionvalue",
 845       plural => "dboptionvalues",
 846       code => [ iter_option_values => $self, \$option ],
 847      ),
 848     );
 849
 850   return $req->dyn_response($template, \%acts);
 851 }
 852
 853 =item a_edit_option
 854
 855 Produce a form to edit the given option.
 856
 857 Parameters:
 858
 859 =over
 860
 861 =item *
 862
 863 id - article id
 864
 865 =item *
 866
 867 option_id - option id.  This must belong to the product identified by
 868 id.
 869
 870 =back
 871
 872 Template: admin/prodopt_edit
 873
 874 Permission required: bse_edit_prodopt_edit
 875
 876 =cut
 877
 878 sub req_edit_option {
 879   my ($self, $req, $article, $articles, $msg, $errors) = @_;
 880
 881   $req->user_can(bse_edit_prodopt_edit => $article)
 882     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
 883
 884   return $self->_common_option('admin/prodopt_edit', $req, $article,
 885                                $articles, $msg, $errors);
 886 }
 887
 888 my %option_name =
 889   (
 890    name =>
 891    {
 892     description => "Option name",
 893     rules => "required;dh_one_line",
 894     maxlength => 255,
 895    },
 896    default_value =>
 897    {
 898     description => "Default Value",
 899     rules => "positiveint"
 900    }
 901   );
 902
 903 my %option_value =
 904   (
 905    description => "Value",
 906    rules => "required;dh_one_line",
 907    maxlength => 255,
 908   );
 909
 910 =item a_save_option
 911
 912 Saves changes to an option.
 913
 914 On failure perform a service error.
 915
 916 Requires _csrfp for admin_save_option
 917
 918 For Ajax requests (or with a _ parameter), returns JSON like:
 919
 920   {
 921    success: 1,
 922    option: { <option data> },
 923    values: [ { value data, value data, ... } ]
 924   }
 925
 926 Parameters:
 927
 928 =over
 929
 930 =item *
 931
 932 id - article id
 933
 934 =item *
 935
 936 option_id - id of the option to save, must belong to the product
 937 identified by id.
 938
 939 =item *
 940
 941 name - new value for the name field
 942
 943 =item *
 944
 945 default_value - id of the default value
 946
 947 =item *
 948
 949 save_enabled - if supplied and true, set enabled from the enabled
 950 parameter.
 951
 952 =item *
 953
 954 enabled - If supplied and true, enable the option, otherwise disable
 955 it.  Ignored unless save_enabled is true.
 956
 957 =item *
 958
 959 valueI<value-id> - set the displayed value for the value record
 960 identified by I<value-id>.  If these aren't supplied the values aren't
 961 changed.
 962
 963 =back
 964
 965 Permission required: bse_edit_prodopt_save
 966
 967 =cut
 968
 969 sub req_save_option {
 970   my ($self, $req, $article, $articles) = @_;
 971
 972   my $cgi = $req->cgi;
 973
 974   $req->check_csrf("admin_save_option")
 975     or return $self->csrf_error($req, $article, "admin_save_option", "Save Product Option");
 976
 977   $req->user_can(bse_edit_prodopt_edit => $article)
 978     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
 979
 980   my %errors;
 981   my $option = $self->_get_option($req, $article, \%errors);
 982   keys %errors
 983     and return $self->_service_error($req, $article, $articles, undef, \%errors, 'FIELD', "req_edit_option");
 984   $req->validate(fields => \%option_name,
 985                  errors => \%errors);
 986   my @values = $option->values;
 987   my %fields = map {; "value$_->{id}" => \%option_value } @values;
 988   $req->validate(fields => \%fields,
 989                  errors => \%errors,
 990                  optional => 1);
 991   my $default_value = $cgi->param('default_value');
 992   if (!$errors{default_value} && $default_value) {
 993     grep $_->{id} == $default_value, @values
 994       or $errors{default_value} = "Unknown value selected as default";
 995   }
 996
 997   $DB::single = 1;
 998   my @new_values;
 999   my $index = 1;
1000   while ($index < 10 && defined $cgi->param("newvalue$index")) {
1001     my $field = "newvalue$index";
1002     my $value = $cgi->param($field);
1003     $req->validate(fields => { $field => \%option_value },
1004                    errors => \%errors);
1005     push @new_values, $value;
1006
1007     ++$index;
1008   }
1009
1010   keys %errors
1011     and return $self->_service_error($req, $article, $articles, undef, \%errors, "FIELD", "req_edit_option");
1012
1013   my $name = $cgi->param("name");
1014   defined $name
1015     and $option->set_name($name);
1016   defined $default_value
1017     and $option->set_default_value($default_value);
1018   if ($cgi->param("save_enabled")) {
1019     my $enabled = $cgi->param("enabled") ? 1 : 0;
1020     $option->set_enabled($enabled);
1021   }
1022   $option->save;
1023   for my $value (@values) {
1024     my $new_value = $cgi->param("value$value->{id}");
1025     if (defined $new_value && $new_value ne $value->value) {
1026       $value->set_value($new_value);
1027       $value->save;
1028     }
1029   }
1030   my $order = @values ? $values[-1]->display_order : time;
1031   for my $value (@new_values) {
1032     BSE::TB::ProductOptionValues->make
1033         (
1034          product_option_id => $option->id,
1035          value => $value,
1036          display_order => ++$order,
1037         );
1038   }
1039
1040   $req->is_ajax
1041     and return $req->json_content
1042       (
1043        success => 1,
1044        option => $option->data_only,
1045        values => [ map $_->data_only, @values ],
1046       );
1047
1048   return $self->refresh($article, $req->cgi, undef,
1049                         "Option '" . $option->name . "' saved");
1050 }
1051
1052 =item a_delconf_option
1053
1054 Produce a form to confirm deletion of the given option.
1055
1056 Parameters:
1057
1058 =over
1059
1060 =item *
1061
1062 id - article id
1063
1064 =item *
1065
1066 option_id - option id.  This must belong to the product identified by
1067 id.
1068
1069 =back
1070
1071 Template: admin/prodopt_delete
1072
1073 =cut
1074
1075 sub req_delconf_option {
1076   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1077
1078   $req->user_can(bse_edit_prodopt_delete => $article)
1079     or return $self->_service_error($req, $article, $articles, "Insufficient product access to delete options");
1080
1081   return $self->_common_option('admin/prodopt_delete', $req, $article,
1082                                $articles, $msg, $errors);
1083 }
1084
1085 =item a_delete_option
1086
1087 Delete the given option.
1088
1089 On failure perform a service error.
1090
1091 Requires _csrfp for admin_delete_option
1092
1093 For Ajax requests (or with a _ parameter), returns JSON like:
1094
1095   {
1096    success: 1,
1097   }
1098
1099 Permission required: bse_edit_prodopt_delete
1100
1101 =cut
1102
1103 sub req_delete_option {
1104   my ($self, $req, $article, $articles) = @_;
1105
1106   $req->check_csrf("admin_delete_option")
1107     or return $self->csrf_error($req, $article, "admin_delete_option", "Delete Product Option");
1108
1109   $req->user_can(bse_edit_prodopt_delete => $article)
1110     or return $self->_service_error($req, $article, $articles, "Insufficient product access to delete options");
1111
1112   my %errors;
1113   my $option = $self->_get_option($req, $article, \%errors);
1114   keys %errors
1115     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1116   my @values = $option->values;
1117
1118   for my $value (@values) {
1119     $value->remove;
1120   }
1121   $option->remove;
1122
1123   $req->is_ajax
1124     and return $req->json_content
1125       (
1126        success => 1
1127       );
1128
1129   return $self->refresh($article, $req->cgi, undef, "Option deleted");
1130 }
1131
1132
1133 my %add_option_value_fields =
1134   (
1135    option_id =>
1136    {
1137     description => "Option id",
1138     rules => "required;positiveint",
1139    },
1140    value =>
1141    {
1142     description => "Value",
1143     rules => "required;dh_one_line",
1144     maxlength => 255,
1145    },
1146   );
1147
1148 =item a_add_option_value
1149
1150 Add a value to a product option.
1151
1152 On failure perform a service error, see BSE::Edit::Article::_service_error.
1153
1154 Requires _csrfp for admin_add_option_value
1155
1156 For Ajax requests returns JSON like
1157
1158  { success: 1, value: (valueobject) }
1159
1160 Standard redirect on success otherwise.
1161
1162 Parameters:
1163
1164 =over
1165
1166 =item *
1167
1168 id - article id
1169
1170 =item *
1171
1172 option_id - id of the option to add the value to
1173
1174 =item *
1175
1176 value - text of the value to add.
1177
1178 =back
1179
1180 Permission required: bse_edit_prodopt_edit
1181
1182 =cut
1183
1184 sub req_add_option_value {
1185   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1186
1187   $req->check_csrf("admin_add_option_value")
1188     or return $self->csrf_error($req, $article, "admin_add_option_value", "Add Product Option Value");
1189
1190   $req->user_can(bse_edit_prodopt_edit => $article)
1191     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1192
1193   my %errors;
1194   $req->validate(fields => \%add_option_value_fields,
1195                  errors => \%errors);
1196   my $option;
1197   my $cgi = $req->cgi;
1198   unless ($errors{option_id}) {
1199     require BSE::TB::ProductOptions;
1200     $option = BSE::TB::ProductOptions->getByPkey($cgi->param("option_id"));
1201     defined $option && $option->{product_id}
1202       or $errors{option_id} = "Bad option id - either unknown or for a different product";
1203   }
1204   keys %errors
1205     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1206
1207   my $value = $cgi->param("value");
1208   require BSE::TB::ProductOptionValues;
1209   my $entry = BSE::TB::ProductOptionValues->make
1210     (
1211      product_option_id => $option->{id},
1212      value => $value,
1213      display_order => time,
1214     );
1215
1216   $req->is_ajax
1217     and return $req->json_content
1218       (
1219        success => 1,
1220        value => $entry->data_only
1221       );
1222
1223   return $self->refresh($article, $cgi, undef, "Value added");
1224 }
1225
1226
1227 my %option_value_id =
1228   (
1229    value_id =>
1230    {
1231     rules => "required;positiveint",
1232    },
1233   );
1234
1235 sub _get_option_value {
1236   my ($self, $req, $article, $errors) = @_;
1237
1238   my $option_value;
1239   my $cgi = $req->cgi;
1240   $req->validate(fields => \%option_value_id,
1241                  errors => $errors);
1242   unless ($errors->{value_id}) {
1243     require BSE::TB::ProductOptionValues;
1244     $option_value = BSE::TB::ProductOptionValues->getByPkey($cgi->param("value_id"));
1245     $option_value
1246       or $errors->{value_id} = "Unknown option value id";
1247   }
1248   my $option;
1249   unless ($errors->{value_id}) {
1250     $option = $option_value->option;
1251     defined $option && $option->{product_id} == $article->{id}
1252       or $errors->{value_id} = "Value has no option or doesn't belong to the product";
1253   }
1254
1255   $errors->{value_id}
1256     and return;
1257
1258   return wantarray ? ( $option_value, $option ) : $option_value ;
1259 }
1260
1261 sub _common_option_value {
1262   my ($self, $template, $req, $article, $articles, $msg, $errors) = @_;
1263
1264   my %errors;
1265   my ($option_value, $option) = $self->_get_option_value($req, $article, \%errors);
1266   keys %errors
1267     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1268
1269   $req->set_variable(option => $option);
1270   $req->set_variable(option_value => $option_value);
1271   my %acts;
1272   %acts =
1273     (
1274      $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors),
1275      option_value => [ \&tag_hash, $option_value ],
1276      option => [ \&tag_hash, $option ],
1277     );
1278
1279   return $req->dyn_response($template, \%acts);
1280 }
1281
1282 =item a_edit_option_value
1283
1284 Displays a form to edit the value for a given option.
1285
1286 Parameters:
1287
1288 =over
1289
1290 =item *
1291
1292 id - id of the product
1293
1294 =item *
1295
1296 value_id - id of he product option value to edit, must belong to the
1297 given product.
1298
1299 =back
1300
1301 Template: admin/prodopt_value_edit
1302
1303 Permission required: bse_edit_prodopt_edit
1304
1305 =cut
1306
1307 sub req_edit_option_value {
1308   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1309
1310   $req->user_can(bse_edit_prodopt_edit => $article)
1311     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1312
1313   return $self->_common_option_value('admin/prodopt_value_edit', $req,
1314                                      $article, $articles, $msg, $errors);
1315 }
1316
1317 my %save_option_value_fields =
1318   (
1319    value =>
1320    {
1321     rules => "required;dh_one_line",
1322     maxlength => 255,
1323    },
1324   );
1325
1326 =item a_save_option_value
1327
1328 Saves changes to an option.
1329
1330 On failure perform a service error.
1331
1332 Requires _csrfp for admin_save_option_value
1333
1334 For Ajax requests (or with a _ parameter), returns JSON like:
1335
1336   {
1337    success: 1,
1338    value: { value data }
1339   }
1340
1341 Parameters:
1342
1343 =over
1344
1345 =item *
1346
1347 id - article id
1348
1349 =item *
1350
1351 value_id - id of the value to save, must belong to the product
1352 identified by id.
1353
1354 =item *
1355
1356 value - new displayed value for the option value.
1357
1358 =back
1359
1360 Permission required: bse_edit_prodopt_edit
1361
1362 =cut
1363
1364 sub req_save_option_value {
1365   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1366
1367   $req->check_csrf("admin_save_option_value")
1368     or return $self->csrf_error($req, $article, "admin_save_option_value", "Save Product Option Value");
1369
1370   $req->user_can(bse_edit_prodopt_edit => $article)
1371     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1372
1373   my %errors;
1374   $req->validate(fields => \%save_option_value_fields,
1375                  errors => \%errors);
1376   my $option_value = $self->_get_option_value($req, $article, \%errors);
1377   keys %errors
1378     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1379
1380   my $cgi = $req->cgi;
1381   $option_value->{value} = $cgi->param("value");
1382   $option_value->save;
1383
1384   $req->is_ajax
1385     and return $req->json_content
1386       (
1387        success => 1,
1388        value => $option_value->data_only
1389       );
1390
1391   return $self->refresh($article, $cgi, undef, "Value saved");
1392 }
1393
1394 =item a_confdel_option_value
1395
1396 Displays a page confirming deletion of a product option value.
1397
1398 Parameters:
1399
1400 =over
1401
1402 =item *
1403
1404 id - article id
1405
1406 =item *
1407
1408 value_id - option value id
1409
1410 =back
1411
1412 Template: admin/prodopt_value_delete
1413
1414 Permission required: bse_edit_prodopt_edit
1415
1416 =cut
1417
1418 sub req_confdel_option_value {
1419   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1420
1421   $req->user_can(bse_edit_prodopt_edit => $article)
1422     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1423
1424   return $self->_common_option_value('admin/prodopt_value_delete', $req,
1425                                      $article, $articles, $msg, $errors);
1426 }
1427
1428 =item a_delete_option_value
1429
1430 Deletes a product option.
1431
1432 On failure perform a service error.
1433
1434 Requires _csrfp for admin_delete_option_value
1435
1436 For Ajax requests (or with a _ parameter), returns JSON like:
1437
1438   {
1439    success: 1,
1440   }
1441
1442 Parameters:
1443
1444 =over
1445
1446 =item *
1447
1448 id - article id
1449
1450 =item *
1451
1452 value_id - id of the value to delete, must belong to the product
1453 identified by id.
1454
1455 =back
1456
1457 Permission required: bse_edit_prodopt_edit
1458
1459 =cut
1460
1461 sub req_delete_option_value {
1462   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1463
1464   $req->check_csrf("admin_delete_option_value")
1465     or return $self->csrf_error($req, $article, "admin_delete_option_value", "Delete Product Option Value");
1466
1467   $req->user_can(bse_edit_prodopt_edit => $article)
1468     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1469
1470   my %errors;
1471   my $option_value = $self->_get_option_value($req, $article, \%errors);
1472   keys %errors
1473     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1474
1475   $option_value->remove;
1476
1477   $req->is_ajax
1478     and return $req->json_content
1479       (
1480        success => 1
1481       );
1482
1483   return $self->refresh($article, $req->cgi, undef, "Value removed");
1484 }
1485
1486 sub tag_dboptionsjson {
1487   my ($self, $article) = @_;
1488
1489   my @result;
1490   my @options = $article->db_options;
1491   my @opt_cols = BSE::TB::ProductOption->columns;
1492   for my $option (@options) {
1493     my $entry = $option->data_only;
1494     $entry->{values} = [ map $_->data_only, $option->values ];
1495     push @result, $entry;
1496   }
1497
1498   require JSON;
1499   my $json = JSON->new;
1500   return $json->encode(\@result);
1501 }
1502
1503 sub _option_move {
1504   my ($self, $req, $article, $articles, $direction) = @_;
1505
1506   $req->check_csrf("admin_move_option")
1507     or return $self->csrf_error($req, $article, "admin_move_option", "Move Product Option");
1508
1509   $req->user_can(bse_edit_prodopt_move => $article)
1510     or return $self->_service_error($req, $article, $articles, "Insufficient product access to move options");
1511
1512   my %errors;
1513   my $option = $self->_get_option($req, $article, \%errors);
1514   keys %errors
1515     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1516   my @options = $article->db_options;
1517   my ($index) = grep $options[$_]{id} == $option->{id}, 0 .. $#options
1518     or return $self->_service_error($req, $article, $articles, "Unknown option id");
1519
1520   $options[$index] = $option;
1521
1522   my $other_index = $index + $direction;
1523   $other_index >= 0 && $other_index < @options
1524     or return $self->_service_error($req, $article, $articles, "Can't move option beyond end");
1525
1526   my $other = $options[$other_index];
1527
1528   ($option->{display_order}, $other->{display_order}) =
1529     ($other->{display_order}, $option->{display_order});
1530   $option->save;
1531   $other->save;
1532
1533   if ($req->is_ajax) {
1534     @options = sort { $a->{display_order} <=> $b->{display_order} } @options;
1535     return return $req->json_content
1536       (
1537        success => 1,
1538        order => [ map $_->{id}, @options ]
1539       );
1540   }
1541
1542   return $self->refresh($article, $req->cgi, undef, "Option moved");
1543 }
1544
1545 =item a_option_moveup
1546
1547 =item a_option_movedown
1548
1549 Move a product option up/down through the options for a product.
1550
1551 On failure perform a service error.
1552
1553 Requires _csrfp for admin_move_option
1554
1555 For Ajax requests (or with a _ parameter), returns JSON like:
1556
1557   {
1558    success: 1,
1559    order: [ list of option ids ]
1560   }
1561
1562 Parameters:
1563
1564 =over
1565
1566 =item *
1567
1568 id - article id
1569
1570 =item *
1571
1572 option_id - option id.  This must belong to the product identified by
1573 id.
1574
1575 =back
1576
1577 Permission required: bse_edit_prodopt_move
1578
1579 =cut
1580
1581 sub req_option_moveup {
1582   my ($self, $req, $article, $articles) = @_;
1583
1584   return $self->_option_move($req, $article, $articles, -1);
1585 }
1586
1587 sub req_option_movedown {
1588   my ($self, $req, $article, $articles) = @_;
1589
1590   return $self->_option_move($req, $article, $articles, 1);
1591 }
1592
1593 =item a_option_reorder
1594
1595 Move a product option up/down through the options for a product.
1596
1597 On failure perform a service error.
1598
1599 Requires _csrfp for admin_move_option
1600
1601 For Ajax requests (or with a _ parameter), returns JSON like:
1602
1603   {
1604    success: 1,
1605    order: [ list of option ids ]
1606   }
1607
1608 Parameters:
1609
1610 =over
1611
1612 =item *
1613
1614 id - article id
1615
1616 =item *
1617
1618 option_ids - option ids separated by commas.  These must belong to the
1619 product identified by id.
1620
1621 =back
1622
1623 Permission required: bse_edit_prodopt_move
1624
1625 =cut
1626
1627 sub req_option_reorder {
1628   my ($self, $req, $article, $articles) = @_;
1629
1630   $req->check_csrf("admin_move_option")
1631     or return $self->csrf_error($req, $article, "admin_move_option", "Move Product Option");
1632
1633   $req->user_can(bse_edit_prodopt_move => $article)
1634     or return $self->_service_error($req, $article, $articles, "Insufficient product access to move options");
1635
1636   my @options = $article->db_options;
1637   my @order = map { split ',' } $req->cgi->param('option_ids');
1638   my %options = map { $_->{id} => $_ } @options;
1639   my @new_options;
1640   for my $id (@order) {
1641     my $option = delete $options{$id}
1642       or next;
1643     push @new_options, $option;
1644   }
1645   push @new_options, sort { $a->{display_order} <=> $b->{display_order} } values %options;
1646   my @display_order = map $_->{display_order}, @options;
1647   for my $index (0 .. $#new_options) {
1648     $new_options[$index]{display_order} = $display_order[$index];
1649     $new_options[$index]->save;
1650   }
1651
1652   $req->is_ajax
1653     and return $req->json_content
1654       (
1655         success => 1,
1656         order => [ map $_->{id}, @new_options ]
1657       );
1658
1659   return $self->refresh($article, $req->cgi, undef, "Options reordered");
1660 }
1661
1662 sub _option_value_move {
1663   my ($self, $req, $article, $articles, $direction) = @_;
1664
1665   $req->check_csrf("admin_move_option_value")
1666     or return $self->csrf_error($req, $article, "admin_move_option_value", "Move Product Option Value");
1667
1668   $req->user_can(bse_edit_prodopt_edit => $article)
1669     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1670
1671   my %errors;
1672   my ($option_value, $option) = $self->_get_option_value($req, $article, \%errors);
1673   keys %errors
1674     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1675   my @values = $option->values;
1676   my ($index) = grep $values[$_]{id} == $option_value->{id}, 0 .. $#values
1677     or return $self->_service_error($req, $article, $articles, "Unknown option value id");
1678
1679   $values[$index] = $option_value;
1680
1681   my $other_index = $index + $direction;
1682   $other_index >= 0 && $other_index < @values
1683     or return $self->_service_error($req, $article, $articles, "Can't move option value beyond end");
1684
1685   my $other = $values[$other_index];
1686
1687   ($option_value->{display_order}, $other->{display_order}) =
1688     ($other->{display_order}, $option_value->{display_order});
1689   $option_value->save;
1690   $other->save;
1691
1692   # make sure the json gets the new order
1693   @values[$index, $other_index] = @values[$other_index, $index];
1694
1695   $req->is_ajax
1696     and return $req->json_content
1697       (
1698        success => 1,
1699        order => [ map $_->{id}, @values ]
1700       );
1701
1702   return $self->refresh($article, $req->cgi, undef, "Value moved");
1703 }
1704
1705 =item a_option_value_moveup
1706
1707 =item a_option_value_movedown
1708
1709 Move a product option value up/down through the values for a product
1710 option.
1711
1712 On failure perform a service error.
1713
1714 Requires _csrfp for admin_move_option_value
1715
1716 For Ajax requests (or with a _ parameter), returns JSON like:
1717
1718   {
1719    success: 1,
1720    order: [ list of value ids ]
1721   }
1722
1723 Parameters:
1724
1725 =over
1726
1727 =item *
1728
1729 id - article id
1730
1731 =item *
1732
1733 value_id - option id.  This must belong to the product identified by
1734 id.
1735
1736 =back
1737
1738 Permission required: bse_edit_prodopt_edit
1739
1740 =cut
1741
1742 sub req_option_value_moveup {
1743   my ($self, $req, $article, $articles) = @_;
1744
1745   return $self->_option_value_move($req, $article, $articles, -1);
1746 }
1747
1748 sub req_option_value_movedown {
1749   my ($self, $req, $article, $articles) = @_;
1750
1751   return $self->_option_value_move($req, $article, $articles, 1);
1752 }
1753
1754 =item a_option_value_reorder
1755
1756 Specify a new order for the values belonging to a product option.
1757
1758 On failure perform a service error.
1759
1760 Requires _csrfp for admin_move_option_value
1761
1762 For Ajax requests (or with a _ parameter), returns JSON like:
1763
1764   {
1765    success: 1,
1766    order: [ list of value ids ]
1767   }
1768
1769 Parameters:
1770
1771 =over
1772
1773 =item *
1774
1775 id - article id
1776
1777 =item *
1778
1779 option_id - the option to reorder values for
1780
1781 =item *
1782
1783 value_ids - new order for values specified as value ids separated by
1784 commas.
1785
1786 =back
1787
1788 Permission required: bse_edit_prodopt_edit
1789
1790 =cut
1791
1792 sub req_option_value_reorder {
1793   my ($self, $req, $article, $articles) = @_;
1794
1795   $req->check_csrf("admin_move_option_value")
1796     or return $self->csrf_error($req, $article, "admin_move_option_value", "Move Product Option Value");
1797
1798   $req->user_can(bse_edit_prodopt_edit => $article)
1799     or return $self->_service_error($req, $article, $articles, "Insufficient product access to edit options");
1800
1801   my %errors;
1802   my $option = $self->_get_option($req, $article, \%errors);
1803   keys %errors
1804     and return $self->_service_error($req, $article, $articles, undef, \%errors);
1805   my @order = map { split ',' } $req->cgi->param('value_ids');
1806   my @values = $option->values;
1807   my %values = map { $_->{id} => $_ } @values;
1808   my @new_values;
1809   for my $id (@order) {
1810     my $value = delete $values{$id}
1811       or next;
1812     push @new_values, $value;
1813   }
1814   push @new_values, sort { $a->{display_order} <=> $b->{display_order} } values %values;
1815   my @display_order = map $_->{display_order}, @values;
1816   for my $index (0 .. $#new_values) {
1817     $new_values[$index]{display_order} = $display_order[$index];
1818     $new_values[$index]->save;
1819   }
1820
1821   $req->is_ajax
1822     and return $req->json_content
1823       (
1824         success => 1,
1825         option => $option->data_only,
1826         order => [ map $_->{id}, @new_values ]
1827       );
1828
1829   return $self->refresh($article, $req->cgi, undef, "Values reordered");
1830 }
1831
1832 sub custom_fields {
1833   my ($self) = @_;
1834
1835   my $custom = $self->SUPER::custom_fields();
1836
1837   require DevHelp::Validate;
1838   DevHelp::Validate->import;
1839   return DevHelp::Validate::dh_configure_fields
1840     (
1841      $custom,
1842      $self->cfg,
1843      PRODUCT_CUSTOM_FIELDS_CFG,
1844      BSE::DB->single->dbh,
1845     );
1846 }
1847
1848 sub article_actions {
1849   my $self = shift;
1850
1851   return
1852     (
1853      $self->SUPER::article_actions,
1854      a_add_option => 'req_add_option',
1855      a_confdel_option => 'req_confdel_option',
1856      a_del_option => 'req_del_option',
1857      a_edit_option => 'req_edit_option',
1858      a_save_option => 'req_save_option',
1859      a_delconf_option => 'req_delconf_option',
1860      a_delete_option => 'req_delete_option',
1861      a_get_option => 'req_get_option',
1862      a_edit_option_value => 'req_edit_option_value',
1863      a_save_option_value => 'req_save_option_value',
1864      a_confdel_option_value => 'req_confdel_option_value',
1865      a_delete_option_value => 'req_delete_option_value',
1866      a_add_option_value => 'req_add_option_value',
1867      a_option_value_moveup => 'req_option_value_moveup',
1868      a_option_value_movedown => 'req_option_value_movedown',
1869      a_option_value_reorder => 'req_option_value_reorder',
1870      a_option_moveup => 'req_option_moveup',
1871      a_option_movedown => 'req_option_movedown',
1872      a_option_reorder => 'req_option_reorder',
1873     );
1874 }
1875
1876 1;
1877
1878 =back
1879
1880 =head1 AUTHOR
1881
1882 Tony Cook <tony@develop-help.com>
1883
1884 =cut