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

   1 package BSE::Edit::Article;
   2 use strict;
   3 use base qw(BSE::Edit::Base);
   4 use BSE::Util::Tags qw(tag_error_img tag_article tag_object);
   5 use BSE::Util::SQL qw(now_sqldate now_sqldatetime);
   6 use BSE::Permissions;
   7 use BSE::Util::HTML qw(:default popup_menu);
   8 use BSE::Arrows;
   9 use BSE::CfgInfo qw(custom_class admin_base_url cfg_image_dir cfg_dist_image_uri cfg_image_uri);
  10 use BSE::Util::Iterate;
  11 use BSE::Template;
  12 use BSE::Util::ContentType qw(content_type);
  13 use BSE::Regen 'generate_article';
  14 use DevHelp::Date qw(dh_parse_date dh_parse_sql_date);
  15 use List::Util qw(first);
  16 use constant MAX_FILE_DISPLAYNAME_LENGTH => 255;
  17 use constant ARTICLE_CUSTOM_FIELDS_CFG => "article custom fields";
  18
  19 our $VERSION = "1.057";
  20
  21 =head1 NAME
  22
  23   BSE::Edit::Article - editing functionality for BSE articles
  24
  25 =head1 DESCRIPTION
  26
  27 Provides the base article editing functionality.
  28
  29 This is badly organized and documented.
  30
  31 =head1 METHODS
  32
  33 =over
  34
  35 =cut
  36
  37 sub not_logged_on {
  38   my ($self, $req) = @_;
  39
  40   if ($req->is_ajax) {
  41     # AJAX/Prototype request
  42     return $req->json_content
  43       (
  44        {
  45         success => 0,
  46         message => "Access forbidden: user not logged on",
  47         errors => {},
  48         error_code => "LOGON",
  49        }
  50       );
  51   }
  52   elsif ($req->cgi->param('_service')) {
  53     return
  54       {
  55        content => 'Access Forbidden: login timed out',
  56        headers => [
  57                    "Status: 403", # forbidden
  58                   ],
  59       };
  60   }
  61   else {
  62     BSE::Template->get_refresh($req->url('logon'), $req->cfg);
  63   }
  64 }
  65
  66 sub article_dispatch {
  67   my ($self, $req, $article, $articles) = @_;
  68
  69   BSE::Permissions->check_logon($req)
  70     or return $self->not_logged_on($req);
  71
  72   my $cgi = $req->cgi;
  73   my $action;
  74   my %actions = $self->article_actions;
  75   for my $check (keys %actions) {
  76     if ($cgi->param($check) || $cgi->param("$check.x")
  77        || $cgi->param("a_$check") || $cgi->param("a_$check.x")) {
  78       $action = $check;
  79       last;
  80     }
  81   }
  82   my @extraargs;
  83   unless ($action) {
  84     ($action, @extraargs) = $self->other_article_actions($cgi);
  85   }
  86   $action ||= 'edit';
  87   my $method = $actions{$action};
  88   return $self->$method($req, $article, $articles, @extraargs);
  89 }
  90
  91 sub noarticle_dispatch {
  92   my ($self, $req, $articles) = @_;
  93
  94   BSE::Permissions->check_logon($req)
  95     or return BSE::Template->get_refresh($req->url('logon'), $req->cfg);
  96
  97   my $mymsg;
  98   my $article = $self->_dummy_article($req, $articles, \$mymsg);
  99   unless ($article) {
 100     require BSE::Edit::Site;
 101     my $site = BSE::Edit::Site->new(cfg=>$req->cfg, db=> BSE::DB->single);
 102     return $site->edit_sections($req, $articles, $mymsg);
 103   }
 104
 105   my $cgi = $req->cgi;
 106   my $action = 'add';
 107   my %actions = $self->noarticle_actions;
 108   for my $check (keys %actions) {
 109     if ($cgi->param($check) || $cgi->param("$check.x")) {
 110       $action = $check;
 111       last;
 112     }
 113   }
 114   my $method = $actions{$action};
 115   return $self->$method($req, $article, $articles);
 116 }
 117
 118 sub article_actions {
 119   my ($self) = @_;
 120
 121   return
 122     (
 123      edit => 'edit_form',
 124      save => 'save',
 125      add_stepkid => 'add_stepkid',
 126      del_stepkid => 'del_stepkid',
 127      save_stepkids => 'save_stepkids',
 128      add_stepparent => 'add_stepparent',
 129      del_stepparent => 'del_stepparent',
 130      save_stepparents => 'save_stepparents',
 131      artimg => 'save_image_changes',
 132      addimg => 'add_image',
 133      a_edit_image => 'req_edit_image',
 134      a_save_image => 'req_save_image',
 135      a_order_images => 'req_order_images',
 136      remove => 'remove',
 137      showimages => 'show_images',
 138      process => 'save_image_changes',
 139      removeimg => 'remove_img',
 140      moveimgup => 'move_img_up',
 141      moveimgdown => 'move_img_down',
 142      filelist => 'filelist',
 143      fileadd => 'fileadd',
 144      fileswap => 'fileswap',
 145      filedel => 'filedel',
 146      filesave => 'filesave',
 147      a_edit_file => 'req_edit_file',
 148      a_save_file => 'req_save_file',
 149      hide => 'hide',
 150      unhide => 'unhide',
 151      a_thumb => 'req_thumb',
 152      a_ajax_get => 'req_ajax_get',
 153      a_ajax_save_body => 'req_ajax_save_body',
 154      a_ajax_set => 'req_ajax_set',
 155      a_filemeta => 'req_filemeta',
 156      a_csrfp => 'req_csrfp',
 157      a_tree => 'req_tree',
 158      a_article => 'req_article',
 159      a_config => 'req_config',
 160      a_restepkid => 'req_restepkid',
 161     );
 162 }
 163
 164 sub other_article_actions {
 165   my ($self, $cgi) = @_;
 166
 167   for my $param ($cgi->param) {
 168     if ($param =~ /^removeimg_(\d+)(\.x)?$/) {
 169       return ('removeimg', $1 );
 170     }
 171   }
 172
 173   return;
 174 }
 175
 176 sub noarticle_actions {
 177   return
 178     (
 179      add => 'add_form',
 180      save => 'save_new',
 181      a_csrfp => 'req_csrfp',
 182      a_config => 'req_config',
 183     );
 184 }
 185
 186 sub get_parent {
 187   my ($self, $parentid, $articles) = @_;
 188
 189   if ($parentid == -1) {
 190     return
 191       {
 192        id => -1,
 193        title=>'All Sections',
 194        level => 0,
 195        listed => 0,
 196        parentid => undef,
 197       };
 198   }
 199   else {
 200     return $articles->getByPkey($parentid);
 201   }
 202 }
 203
 204 sub tag_hash {
 205   my ($object, $args) = @_;
 206
 207   my $value = $object->{$args};
 208   defined $value or $value = '';
 209   if ($value =~ /\cJ/ && $value =~ /\cM/) {
 210     $value =~ tr/\cM//d;
 211   }
 212   escape_html($value);
 213 }
 214
 215 sub tag_hash_mbcs {
 216   my ($object, $args) = @_;
 217
 218   my $value = $object->{$args};
 219   defined $value or $value = '';
 220   if ($value =~ /\cJ/ && $value =~ /\cM/) {
 221     $value =~ tr/\cM//d;
 222   }
 223   escape_html($value, '<>&"');
 224 }
 225
 226 sub tag_art_type {
 227   my ($level, $cfg) = @_;
 228
 229   escape_html($cfg->entry('level names', $level, 'Article'));
 230 }
 231
 232 sub tag_if_new {
 233   my ($article) = @_;
 234
 235   !$article->{id};
 236 }
 237
 238 sub reparent_updown {
 239   return 1;
 240 }
 241
 242 sub should_be_catalog {
 243   my ($self, $article, $parent, $articles) = @_;
 244
 245   if ($article->{parentid} && (!$parent || $parent->{id} != $article->{parentid})) {
 246     $parent = $articles->getByPkey($article->{id});
 247   }
 248
 249   my $shopid = $self->cfg->entryErr('articles', 'shop');
 250
 251   return $article->{parentid} && $parent &&
 252     ($article->{parentid} == $shopid ||
 253      $parent->{generator} eq 'BSE::Generate::Catalog');
 254 }
 255
 256 sub possible_parents {
 257   my ($self, $article, $articles, $req) = @_;
 258
 259   my %labels;
 260   my @values;
 261
 262   my $shopid = $self->cfg->entryErr('articles', 'shop');
 263   my @parents = $articles->getBy('level', $article->{level}-1);
 264   @parents = grep { $_->{generator} eq 'BSE::Generate::Article'
 265                       && $_->{id} != $shopid } @parents;
 266
 267   # user can only select parent they can add to
 268   @parents = grep $req->user_can('edit_add_child', $_), @parents;
 269
 270   @values = ( map {$_->{id}} @parents );
 271   %labels = ( map { $_->{id} => "$_->{title} ($_->{id})" } @parents );
 272
 273   if ($article->{level} == 1 && $req->user_can('edit_add_child')) {
 274     push @values, -1;
 275     $labels{-1} = "No parent - this is a section";
 276   }
 277
 278   if ($article->{id} && $self->reparent_updown($article)) {
 279     # we also list the siblings and grandparent (if any)
 280     my @siblings = grep $_->{id} != $article->{id} && $_->{id} != $shopid,
 281     $articles->getBy(parentid => $article->{parentid});
 282     @siblings = grep $req->user_can('edit_add_child', $_), @siblings;
 283     push @values, map $_->{id}, @siblings;
 284     @labels{map $_->{id}, @siblings} =
 285       map { "-- move down a level -- $_->{title} ($_->{id})" } @siblings;
 286
 287     if ($article->{parentid} != -1) {
 288       my $parent = $articles->getByPkey($article->{parentid});
 289       if ($parent->{parentid} != -1) {
 290         my $gparent = $articles->getByPkey($parent->{parentid});
 291         if ($req->user_can('edit_add_child', $gparent)) {
 292           push @values, $gparent->{id};
 293           $labels{$gparent->{id}} =
 294             "-- move up a level -- $gparent->{title} ($gparent->{id})";
 295         }
 296       }
 297       else {
 298         if ($req->user_can('edit_add_child')) {
 299           push @values, -1;
 300           $labels{-1} = $req->catmsg("msg:bse/admin/edit/uplabelsect");
 301         }
 302       }
 303     }
 304   }
 305
 306   return (\@values, \%labels);
 307 }
 308
 309 sub tag_list {
 310   my ($self, $article, $articles, $cgi, $req, $what) = @_;
 311
 312   if ($what eq 'listed') {
 313     my @values = qw(0 1);
 314     my %labels = ( 0=>"No", 1=>"Yes");
 315     if ($article->{level} <= 2) {
 316       $labels{2} = "In Sections, but not menu";
 317       push(@values, 2);
 318     }
 319     else {
 320       $labels{2} = "In content, but not menus";
 321       push(@values, 2);
 322     }
 323     return popup_menu(-name=>'listed',
 324                       -values=>\@values,
 325                       -labels=>\%labels,
 326                       -default=>$article->{listed});
 327   }
 328   else {
 329     my ($values, $labels) = $self->possible_parents($article, $articles, $req);
 330     my $html;
 331     if (defined $article->{parentid}) {
 332       $html = popup_menu(-name=>'parentid',
 333                          -values=> $values,
 334                          -labels => $labels,
 335                          -default => $article->{parentid},
 336                          -override=>1);
 337     }
 338     else {
 339       $html = popup_menu(-name=>'parentid',
 340                          -values=> $values,
 341                          -labels => $labels,
 342                          -override=>1);
 343     }
 344
 345     # munge the html - we display a default value, so we need to wrap the
 346     # default <select /> around this one
 347     $html =~ s!^<select[^>]+>|</select>!!gi;
 348     return $html;
 349   }
 350 }
 351
 352 sub tag_checked {
 353   my ($arg, $acts, $funcname, $templater) = @_;
 354   my ($func, $args) = split ' ', $arg, 2;
 355   return $templater->perform($acts, $func, $args) ? 'checked' : '';
 356 }
 357
 358 sub iter_get_images {
 359   my ($self, $article) = @_;
 360
 361   $article->{id} or return;
 362   $self->get_images($article);
 363 }
 364
 365 sub iter_get_kids {
 366   my ($article, $articles) = @_;
 367
 368   my @children;
 369   $article->{id} or return;
 370   if (UNIVERSAL::isa($article, 'BSE::TB::Article')) {
 371     @children = $article->children;
 372   }
 373   elsif ($article->{id}) {
 374     @children = $articles->children($article->{id});
 375   }
 376
 377   return sort { $b->{displayOrder} <=> $a->{displayOrder} } @children;
 378 }
 379
 380 sub tag_if_have_child_type {
 381   my ($level, $cfg) = @_;
 382
 383   defined $cfg->entry("level names", $level+1);
 384 }
 385
 386 sub tag_is {
 387   my ($args, $acts, $isname, $templater) = @_;
 388
 389   my ($func, $funcargs) = split ' ', $args, 2;
 390   return $templater->perform($acts, $func, $funcargs) ? 'Yes' : 'No';
 391 }
 392
 393 sub default_template {
 394   my ($self, $article, $cfg, $templates) = @_;
 395
 396   if ($article->{parentid}) {
 397     my $template = $cfg->entry("children of $article->{parentid}", "template");
 398     return $template
 399       if $template && grep $_ eq $template, @$templates;
 400   }
 401   if ($article->{level}) {
 402     my $template = $cfg->entry("level $article->{level}", "template");
 403     return $template
 404       if $template && grep $_ eq $template, @$templates;
 405   }
 406   return $templates->[0];
 407 }
 408
 409 sub tag_templates {
 410   my ($self, $article, $cfg, $cgi) = @_;
 411
 412   my @templates = sort { $a->{name} cmp $b->{name} } $self->templates_long($article);
 413   my $default;
 414   if ($article->{template} && grep $_->{name} eq $article->{template}, @templates) {
 415     $default = $article->{template};
 416   }
 417   else {
 418     my @template_names = map $_->{name}, @templates;
 419     $default = $self->default_template($article, $cfg, \@template_names);
 420   }
 421   my %labels =
 422     (
 423      map
 424      { ;
 425        $_->{name} =>
 426        $_->{name} eq $_->{description}
 427          ? $_->{name}
 428            : "$_->{description} ($_->{name})"
 429      } @templates
 430     );
 431   return popup_menu(-name => 'template',
 432                     -values => [ map $_->{name}, @templates ],
 433                     -labels => \%labels,
 434                     -default => $default,
 435                     -override => 1);
 436 }
 437
 438 sub title_images {
 439   my ($self, $article) = @_;
 440
 441   my @title_images;
 442   my $imagedir = cfg_image_dir($self->cfg);
 443   if (opendir TITLE_IMAGES, "$imagedir/titles") {
 444     @title_images = sort
 445       grep -f "$imagedir/titles/$_" && /\.(gif|jpeg|jpg|png)$/i,
 446       readdir TITLE_IMAGES;
 447     closedir TITLE_IMAGES;
 448   }
 449
 450   @title_images;
 451 }
 452
 453 sub tag_title_images  {
 454   my ($self, $article, $cfg, $cgi) = @_;
 455
 456   my @images = $self->title_images($article);
 457   my @values = ( '', @images );
 458   my %labels = ( '' => 'None', map { $_ => $_ } @images );
 459   return $cgi->
 460     popup_menu(-name=>'titleImage',
 461                -values=>\@values,
 462                -labels=>\%labels,
 463                -default=>$article->{id} ? $article->{titleImage} : '',
 464                -override=>1);
 465 }
 466
 467 sub base_template_dirs {
 468   return ( "common" );
 469 }
 470
 471 sub template_dirs {
 472   my ($self, $article) = @_;
 473
 474   my @dirs = $self->base_template_dirs;
 475   if (my $parentid = $article->{parentid}) {
 476     my $section = "children of $parentid";
 477     if (my $dirs = $self->cfg->entry($section, 'template_dirs')) {
 478       push @dirs, split /,/, $dirs;
 479     }
 480   }
 481   if (my $id = $article->{id}) {
 482     my $section = "article $id";
 483     if (my $dirs = $self->{cfg}->entry($section, 'template_dirs')) {
 484       push @dirs, split /,/, $dirs;
 485     }
 486   }
 487   if ($article->{level}) {
 488     push @dirs, $article->{level};
 489     my $dirs = $self->{cfg}->entry("level $article->{level}", 'template_dirs');
 490     push @dirs, split /,/, $dirs if $dirs;
 491   }
 492
 493   @dirs;
 494 }
 495
 496 sub templates {
 497   my ($self, $article) = @_;
 498
 499   my @dirs = $self->template_dirs($article);
 500   my @templates;
 501   my @basedirs = BSE::Template->template_dirs($self->{cfg});
 502   for my $basedir (@basedirs) {
 503     for my $dir (@dirs) {
 504       my $path = File::Spec->catdir($basedir, $dir);
 505       if (-d $path) {
 506         if (opendir TEMPLATE_DIR, $path) {
 507           push(@templates, sort map "$dir/$_",
 508                grep -f "$path/$_" && /\.(tmpl|html)$/i, readdir TEMPLATE_DIR);
 509           closedir TEMPLATE_DIR;
 510         }
 511       }
 512     }
 513   }
 514
 515   # eliminate any dups, and order it nicely
 516   my %seen;
 517   @templates = sort { lc($a) cmp lc($b) }
 518     grep !$seen{$_}++, @templates;
 519
 520   return (@templates, $self->extra_templates($article));
 521 }
 522
 523 sub extra_templates {
 524   my ($self, $article) = @_;
 525
 526   my $basedir = $self->{cfg}->entryVar('paths', 'templates');
 527   my @templates;
 528   if (my $id = $article->{id}) {
 529     push @templates, 'index.tmpl'
 530       if $id == 1 && -f "$basedir/index.html";
 531     push @templates, 'index2.tmpl'
 532       if $id == 2 && -f "$basedir/index2.html";
 533     my $shopid = $self->{cfg}->entryErr('articles', 'shop');
 534     push @templates, "shop_sect.tmpl"
 535       if $id == $shopid && -f "$basedir/shop_sect.tmpl";
 536     my $section = "article $id";
 537     my $extras = $self->{cfg}->entry($section, 'extra_templates');
 538     push @templates, grep /\.(tmpl|html)$/i, split /,/, $extras
 539       if $extras;
 540   }
 541
 542   @templates;
 543 }
 544
 545 sub categories {
 546   my ($self, $articles) = @_;
 547
 548   return $articles->categories;
 549 }
 550
 551 sub edit_parent {
 552   my ($article) = @_;
 553
 554   return '' unless $article->{id} && $article->{id} != -1;
 555   return <<HTML;
 556 <a href="$ENV{SCRIPT_NAME}?id=$article->{parentid}">Edit parent</a> |
 557 HTML
 558 }
 559
 560 sub iter_allkids {
 561   my ($article) = @_;
 562
 563   return unless $article->{id} && $article->{id} > 0;
 564   $article->allkids;
 565 }
 566
 567 sub _load_step_kids {
 568   my ($article, $step_kids) = @_;
 569
 570   require BSE::TB::OtherParents;
 571   my @stepkids = BSE::TB::OtherParents->getBy(parentId=>$article->{id}) if $article->{id};
 572   %$step_kids = map { $_->{childId} => $_ } @stepkids;
 573   $step_kids->{loaded} = 1;
 574 }
 575
 576 sub tag_if_step_kid {
 577   my ($article, $allkids, $rallkid_index, $step_kids) = @_;
 578
 579   _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
 580
 581   my $kid = $allkids->[$$rallkid_index]
 582     or return;
 583   exists $step_kids->{$kid->{id}};
 584 }
 585
 586 sub tag_step_kid {
 587   my ($article, $allkids, $rallkid_index, $step_kids, $arg) = @_;
 588
 589   _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
 590
 591   my $kid = $allkids->[$$rallkid_index]
 592     or return '';
 593   my $step_kid = $step_kids->{$kid->{id}}
 594     or return '';
 595   #use Data::Dumper;
 596   #print STDERR "found kid (want $arg): ", Dumper($kid), Dumper($step_kid);
 597   escape_html($step_kid->{$arg});
 598 }
 599
 600 sub tag_move_stepkid {
 601   my ($self, $cgi, $req, $article, $allkids, $rallkids_index, $arg,
 602       $acts, $funcname, $templater) = @_;
 603
 604   $req->user_can(edit_reorder_children => $article)
 605     or return '';
 606
 607   @$allkids > 1 or return '';
 608
 609   my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 610   $img_prefix = '' unless defined $img_prefix;
 611   $urladd = '' unless defined $urladd;
 612
 613   my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
 614   my $url = $ENV{SCRIPT_NAME} . "?id=$article->{id}";
 615   if ($cgi->param('_t')) {
 616     $url .= "&_t=".$cgi->param('_t');
 617   }
 618   $url .= $urladd;
 619   $url .= "#step";
 620   my $down_url = '';
 621   if ($$rallkids_index < $#$allkids) {
 622     $down_url = "$cgi_uri/admin/move.pl?stepparent=$article->{id}&d=swap&id=$allkids->[$$rallkids_index]{id}&other=$allkids->[$$rallkids_index+1]{id}";
 623   }
 624   my $up_url = '';
 625   if ($$rallkids_index > 0) {
 626     $up_url = "$cgi_uri/admin/move.pl?stepparent=$article->{id}&d=swap&id=$allkids->[$$rallkids_index]{id}&other=$allkids->[$$rallkids_index-1]{id}";
 627   }
 628
 629   return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
 630 }
 631
 632 sub possible_stepkids {
 633   my ($req, $article, $articles, $stepkids) = @_;
 634
 635   $req->user_can(edit_stepkid_add => $article)
 636     or return;
 637
 638   $article->{id} == -1
 639     and return;
 640
 641   my @possible = sort { lc $a->{title} cmp lc $b->{title} }
 642      $article->possible_stepchildren;
 643   if ($req->access_control && $req->cfg->entry('basic', 'access_filter_steps', 0)) {
 644     @possible = grep $req->user_can(edit_stepparent_add => $_->{id}), @possible;
 645   }
 646   return @possible;
 647 }
 648
 649 sub tag_possible_stepkids {
 650   my ($step_kids, $req, $article, $possstepkids, $articles, $cgi) = @_;
 651
 652   _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
 653   @$possstepkids = possible_stepkids($req, $article, $articles, $step_kids)
 654     unless @$possstepkids;
 655   my %labels = map { $_->{id} => "$_->{title} ($_->{id})" } @$possstepkids;
 656   return
 657     popup_menu(-name=>'stepkid',
 658                -values=> [ map $_->{id}, @$possstepkids ],
 659                -labels => \%labels);
 660 }
 661
 662 sub tag_if_possible_stepkids {
 663   my ($step_kids, $req, $article, $possstepkids, $articles, $cgi) = @_;
 664
 665   _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
 666   @$possstepkids = possible_stepkids($req, $article, $articles, $step_kids)
 667     unless @$possstepkids;
 668
 669   @$possstepkids;
 670 }
 671
 672 sub iter_get_stepparents {
 673   my ($article) = @_;
 674
 675   return unless $article->{id} && $article->{id} > 0;
 676
 677   require BSE::TB::OtherParents;
 678   BSE::TB::OtherParents->getBy(childId=>$article->{id});
 679 }
 680
 681 sub tag_ifStepParents {
 682   my ($args, $acts, $funcname, $templater) = @_;
 683
 684   return $templater->perform($acts, 'ifStepparents', '');
 685 }
 686
 687 sub tag_stepparent_targ {
 688   my ($article, $targs, $rindex, $arg) = @_;
 689
 690   if ($article->{id} && $article->{id} > 0 && !@$targs) {
 691     @$targs = $article->step_parents;
 692   }
 693   escape_html($targs->[$$rindex]{$arg});
 694 }
 695
 696 sub tag_move_stepparent {
 697   my ($self, $cgi, $req, $article, $stepparents, $rindex, $arg,
 698       $acts, $funcname, $templater) = @_;
 699
 700   $req->user_can(edit_reorder_stepparents => $article)
 701     or return '';
 702
 703   @$stepparents > 1 or return '';
 704
 705   my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 706   $img_prefix = '' unless defined $img_prefix;
 707   $urladd = '' unless defined $urladd;
 708
 709   my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
 710   my $images_uri = cfg_dist_image_uri();
 711   my $html = '';
 712   my $url = $ENV{SCRIPT_NAME} . "?id=$article->{id}";
 713   if ($cgi->param('_t')) {
 714     $url .= "&_t=".$cgi->param('_t');
 715   }
 716   $url .= $urladd;
 717   $url .= "#stepparents";
 718   my $blank = qq!<img src="$images_uri/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" alt="" />!;
 719   my $down_url = '';
 720   if ($$rindex < $#$stepparents) {
 721     $down_url = "$cgi_uri/admin/move.pl?stepchild=$article->{id}&id=$stepparents->[$$rindex]{parentId}&d=swap&other=$stepparents->[$$rindex+1]{parentId}";
 722   }
 723   my $up_url = '';
 724   if ($$rindex > 0) {
 725     $up_url = "$cgi_uri/admin/move.pl?stepchild=$article->{id}&id=$stepparents->[$$rindex]{parentId}&d=swap&other=$stepparents->[$$rindex-1]{parentId}";
 726   }
 727
 728   return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
 729 }
 730
 731 sub _stepparent_possibles {
 732   my ($req, $article, $articles, $targs) = @_;
 733
 734   $req->user_can(edit_stepparent_add => $article)
 735     or return;
 736
 737   $article->{id} == -1
 738     and return;
 739
 740   @$targs = $article->step_parents unless @$targs;
 741   my %targs = map { $_->{id}, 1 } @$targs;
 742   my @possibles = $article->possible_stepparents;
 743   if ($req->access_control && $req->cfg->entry('basic', 'access_filter_steps', 0)) {
 744     @possibles = grep $req->user_can(edit_stepkid_add => $_->{id}), @possibles;
 745   }
 746   @possibles = sort { lc $a->{title} cmp lc $b->{title} } @possibles;
 747
 748   return @possibles;
 749 }
 750
 751 sub tag_if_stepparent_possibles {
 752   my ($req, $article, $articles, $targs, $possibles) = @_;
 753
 754   if ($article->{id} && $article->{id} > 0 && !@$possibles) {
 755     @$possibles = _stepparent_possibles($req, $article, $articles, $targs);
 756   }
 757   scalar @$possibles;
 758 }
 759
 760 sub tag_stepparent_possibles {
 761   my ($cgi, $req, $article, $articles, $targs, $possibles) = @_;
 762
 763   if ($article->{id} && $article->{id} > 0 && !@$possibles) {
 764     @$possibles = _stepparent_possibles($req, $article, $articles, $targs);
 765   }
 766   popup_menu(-name=>'stepparent',
 767              -values => [ map $_->{id}, @$possibles ],
 768              -labels => { map { $_->{id}, "$_->{title} ($_->{id})" }
 769                           @$possibles });
 770 }
 771
 772 sub iter_files {
 773   my ($self, $article) = @_;
 774
 775   return $self->get_files($article);
 776 }
 777
 778 sub get_files {
 779   my ($self, $article) = @_;
 780
 781   return unless $article->{id} && $article->{id} > 0;
 782
 783   return $article->files;
 784 }
 785
 786 sub tag_edit_parent {
 787   my ($article) = @_;
 788
 789   return '' unless $article->{id} && $article->{id} != -1;
 790
 791   return <<HTML;
 792 <a href="$ENV{SCRIPT_NAME}?id=$article->{parentid}">Edit parent</a> |
 793 HTML
 794 }
 795
 796 sub tag_if_children {
 797   my ($args, $acts, $funcname, $templater) = @_;
 798
 799   return $templater->perform($acts, 'ifChildren', '');
 800 }
 801
 802 sub tag_movechild {
 803   my ($self, $req, $article, $kids, $rindex, $arg,
 804       $acts, $funcname, $templater) = @_;
 805
 806   $req->user_can('edit_reorder_children', $article)
 807     or return '';
 808
 809   @$kids > 1 or return '';
 810
 811   $$rindex >=0 && $$rindex < @$kids
 812     or return '** movechild can only be used in the children iterator **';
 813
 814   my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 815   $img_prefix = '' unless defined $img_prefix;
 816   $urladd = '' unless defined $urladd;
 817
 818   my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
 819   my $images_uri = cfg_dist_image_uri();
 820   my $urlbase = admin_base_url($req->cfg);
 821   my $refresh_url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
 822   my $t = $req->cgi->param('_t');
 823   if ($t && $t =~ /^\w+$/) {
 824     $refresh_url .= "&_t=$t";
 825   }
 826
 827   $refresh_url .= $urladd;
 828
 829   my $id = $kids->[$$rindex]{id};
 830   my $down_url = '';
 831   if ($$rindex < $#$kids) {
 832     $down_url = "$cgi_uri/admin/move.pl?id=$id&d=down&edit=1&all=1";
 833   }
 834   my $up_url = '';
 835   if ($$rindex > 0) {
 836     $up_url = "$cgi_uri/admin/move.pl?id=$id&d=up&edit=1&all=1"
 837   }
 838
 839   return make_arrows($req->cfg, $down_url, $up_url, $refresh_url, $img_prefix);
 840 }
 841
 842 sub tag_category {
 843   my ($self, $articles, $article) = @_;
 844
 845   my @cats = $self->categories($articles);
 846
 847   my %labels = map { $_->{id}, $_->{name} } @cats;
 848
 849   return popup_menu(-name => 'category',
 850                     -values => [ map $_->{id}, @cats ],
 851                     -labels => \%labels,
 852                     -default => $article->{category});
 853 }
 854
 855 sub tag_edit_link {
 856   my ($cfg, $article, $args, $acts, $funcname, $templater) = @_;
 857   my ($which, $name) = split / /, $args, 2;
 858   $name ||= 'Edit';
 859   my $gen_class;
 860   if ($acts->{$which}
 861       && ($gen_class = $templater->perform($acts, $which, 'generator'))) {
 862     eval "use $gen_class";
 863     unless ($@) {
 864       my $gen = $gen_class->new(top => $article, cfg => $cfg);
 865       my $link = $gen->edit_link($templater->perform($acts, $which, 'id'));
 866       return qq!<a href="$link">$name</a>!;
 867     }
 868   }
 869   return '';
 870 }
 871
 872 sub tag_imgmove {
 873   my ($req, $article, $rindex, $images, $arg,
 874       $acts, $funcname, $templater) = @_;
 875
 876   $req->user_can(edit_images_reorder => $article)
 877     or return '';
 878
 879   @$images > 1 or return '';
 880
 881   $$rindex >= 0 && $$rindex < @$images
 882     or return '** imgmove can only be used in image iterator **';
 883
 884   my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 885   $img_prefix = '' unless defined $img_prefix;
 886   $urladd = '' unless defined $urladd;
 887
 888   my $urlbase = admin_base_url($req->cfg);
 889   my $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
 890   my $t = $req->cgi->param('_t');
 891   if ($t && $t =~ /^\w+$/) {
 892     $url .= "&_t=$t";
 893   }
 894   $url .= $urladd;
 895
 896   my $image = $images->[$$rindex];
 897   my $csrfp = $req->get_csrf_token("admin_move_image");
 898   my $baseurl = "$ENV{SCRIPT_NAME}?id=$article->{id}&imageid=$image->{id}&";
 899   $baseurl .= "_csrfp=$csrfp&";
 900   my $down_url = "";
 901   if ($$rindex < $#$images) {
 902     $down_url = $baseurl . "moveimgdown=1";
 903   }
 904   my $up_url = "";
 905   if ($$rindex > 0) {
 906     $up_url = $baseurl . "moveimgup=1";
 907   }
 908   return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
 909 }
 910
 911 sub tag_movefiles {
 912   my ($self, $req, $article, $files, $rindex, $arg,
 913       $acts, $funcname, $templater) = @_;
 914
 915   $req->user_can('edit_files_reorder', $article)
 916     or return '';
 917
 918   @$files > 1 or return '';
 919
 920   my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 921   $img_prefix = '' unless defined $img_prefix;
 922   $urladd = '' unless defined $urladd;
 923
 924   $$rindex >= 0 && $$rindex < @$files
 925     or return '** movefiles can only be used in the files iterator **';
 926
 927   my $urlbase = admin_base_url($req->cfg);
 928   my $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}$urladd";
 929   my $t = $req->cgi->param('_t');
 930   if ($t && $t =~ /^\w+$/) {
 931     $url .= "&_t=$t";
 932   }
 933
 934   my $down_url = "";
 935   my $csrfp = $req->get_csrf_token("admin_move_file");
 936   my $baseurl = "$ENV{SCRIPT_NAME}?fileswap=1&id=$article->{id}&";
 937   $baseurl .= "_csrfp=$csrfp&";
 938   if ($$rindex < $#$files) {
 939     $down_url = $baseurl . "file1=$files->[$$rindex]{id}&file2=$files->[$$rindex+1]{id}";
 940   }
 941   my $up_url = "";
 942   if ($$rindex > 0) {
 943     $up_url = $baseurl . "file1=$files->[$$rindex]{id}&file2=$files->[$$rindex-1]{id}";
 944   }
 945
 946   return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
 947 }
 948
 949 sub tag_old {
 950   my ($article, $cgi, $args, $acts, $funcname, $templater) = @_;
 951
 952   my ($col, $func, $funcargs) = split ' ', $args, 3;
 953   my $value = $cgi->param($col);
 954   if (defined $value) {
 955     return escape_html($value);
 956   }
 957   else {
 958     if ($func) {
 959       return $templater->perform($acts, $func, $funcargs);
 960     }
 961     else {
 962       $value = $article->{$args};
 963       defined $value or $value = '';
 964       return escape_html($value);
 965     }
 966   }
 967 }
 968
 969 sub iter_admin_users {
 970   require BSE::TB::AdminUsers;
 971
 972   BSE::TB::AdminUsers->all;
 973 }
 974
 975 sub iter_admin_groups {
 976   require BSE::TB::AdminGroups;
 977
 978   BSE::TB::AdminGroups->all;
 979 }
 980
 981 sub tag_if_field_perm {
 982   my ($req, $article, $field) = @_;
 983
 984   unless ($field =~ /^\w+$/) {
 985     print STDERR "Bad fieldname '$field'\n";
 986     return;
 987   }
 988   if ($article->{id}) {
 989     return $req->user_can("edit_field_edit_$field", $article);
 990   }
 991   else {
 992     #print STDERR "adding, always successful\n";
 993     return 1;
 994   }
 995 }
 996
 997 sub tag_default {
 998   my ($self, $req, $article, $args, $acts, $funcname, $templater) = @_;
 999
1000   my ($col, $func, $funcargs) = split ' ', $args, 3;
1001   if ($article->{id}) {
1002     if ($func) {
1003       return $templater->perform($acts, $func, $funcargs);
1004     }
1005     else {
1006       my $value = $article->{$args};
1007       defined $value or $value = '';
1008       return escape_html($value, '<>&"');
1009     }
1010   }
1011   else {
1012     my $value = $self->default_value($req, $article, $col);
1013     defined $value or $value = '';
1014     return escape_html($value, '<>&"');
1015   }
1016 }
1017
1018 sub iter_flags {
1019   my ($self) = @_;
1020
1021   $self->flags;
1022 }
1023
1024 sub tag_if_flag_set {
1025   my ($article, $arg, $acts, $funcname, $templater) = @_;
1026
1027   my @args = DevHelp::Tags->get_parms($arg, $acts, $templater);
1028   @args or return;
1029
1030   return index($article->{flags}, $args[0]) >= 0;
1031 }
1032
1033 sub iter_crumbs {
1034   my ($article, $articles) = @_;
1035
1036   my @crumbs;
1037   my $temp = $article;
1038   defined($temp->{parentid}) or return;
1039   while ($temp->{parentid} > 0
1040          and my $crumb = $articles->getByPkey($temp->{parentid})) {
1041     unshift @crumbs, $crumb;
1042     $temp = $crumb;
1043   }
1044
1045   @crumbs;
1046 }
1047
1048 sub tag_typename {
1049   my ($args, $acts, $funcname, $templater) = @_;
1050
1051   exists $acts->{$args} or return "** need an article name **";
1052   my $generator = $templater->perform($acts, $args, 'generator');
1053
1054   $generator =~ /^(?:BSE::)?Generate::(\w+)$/
1055     or return "** invalid generator $generator **";
1056
1057   return $1;
1058 }
1059
1060 sub _get_thumbs_class {
1061   my ($self) = @_;
1062
1063   $self->{cfg}->entry('editor', 'allow_thumb', 0)
1064     or return;
1065
1066   my $class = $self->{cfg}->entry('editor', 'thumbs_class')
1067     or return;
1068
1069   (my $filename = "$class.pm") =~ s!::!/!g;
1070   eval { require $filename; };
1071   if ($@) {
1072     print STDERR "** Error loading thumbs_class $class ($filename): $@\n";
1073     return;
1074   }
1075   my $obj;
1076   eval { $obj = $class->new($self->{cfg}) };
1077   if ($@) {
1078     print STDERR "** Error creating thumbs objects $class: $@\n";
1079     return;
1080   }
1081
1082   return $obj;
1083 }
1084
1085 sub tag_thumbimage {
1086   my ($cfg, $thumbs_obj, $current_image, $args) = @_;
1087
1088   $thumbs_obj or return '';
1089
1090   $$current_image or return '** no current image **';
1091
1092   my $imagedir = cfg_image_dir($cfg);
1093
1094   my $filename = "$imagedir/$$current_image->{image}";
1095   -e $filename or return "** image file missing **";
1096
1097   defined $args && $args =~ /\S/
1098     or $args = "editor";
1099
1100   my $image = $$current_image;
1101   return $image->thumb
1102     (
1103      geo => $args,
1104      cfg => $cfg,
1105      nolink => 1,
1106     );
1107 }
1108
1109 sub tag_file_display {
1110   my ($self, $files, $file_index) = @_;
1111
1112   $$file_index >= 0 && $$file_index < @$files
1113     or return "* file_display only usable inside a files iterator *";
1114   my $file = $files->[$$file_index];
1115
1116   my $disp_type = $self->cfg->entry("editor", "file_display", "");
1117
1118   return $file->inline
1119     (
1120      cfg => $self->cfg,
1121      field => $disp_type,
1122     );
1123 }
1124
1125 sub tag_image {
1126   my ($self, $cfg, $rcurrent, $args) = @_;
1127
1128   my $im = $$rcurrent
1129     or return '';
1130
1131   my ($align, $rest) = split ' ', $args, 2;
1132
1133   if ($align && exists $im->{$align}) {
1134     if ($align eq 'src') {
1135       return escape_html($im->image_url($self->{cfg}));
1136     }
1137     else {
1138       return escape_html($im->{$align});
1139     }
1140   }
1141   else {
1142     return $im->formatted
1143       (
1144        cfg => $cfg,
1145        align => $align,
1146        extras => $rest,
1147       );
1148   }
1149 }
1150
1151 sub iter_tags {
1152   my ($self, $article) = @_;
1153
1154   $article->{id}
1155     or return;
1156
1157   return $article->tag_objects;
1158 }
1159
1160 my %base_custom_validation =
1161   (
1162    customDate1 =>
1163    {
1164     rules => "date",
1165     htmltype => "text",
1166     width => 10,
1167     default => "",
1168     type => "date",
1169    },
1170    customDate2 =>
1171    {
1172     rules => "date",
1173     htmltype => "text",
1174     width => 10,
1175     default => "",
1176     type => "date",
1177    },
1178    customStr1 =>
1179    {
1180     htmltype => "text",
1181     default => "",
1182    },
1183    customStr2 =>
1184    {
1185     htmltype => "text",
1186     default => "",
1187    },
1188    customInt1 =>
1189    {
1190     rules => "integer",
1191     htmltype => "text",
1192     width => 10,
1193     default => "",
1194    },
1195    customInt2 =>
1196    {
1197     rules => "integer",
1198     htmltype => "text",
1199     width => 10,
1200     default => "",
1201    },
1202    customInt3 =>
1203    {
1204     rules => "integer",
1205     htmltype => "text",
1206     width => 10,
1207     default => "",
1208    },
1209    customInt4 =>
1210    {
1211     rules => "integer",
1212     htmltype => "text",
1213     width => 10,
1214     default => "",
1215    },
1216   );
1217
1218 sub custom_fields {
1219   my $self = shift;
1220
1221   require DevHelp::Validate;
1222   DevHelp::Validate->import;
1223   return DevHelp::Validate::dh_configure_fields
1224     (
1225      \%base_custom_validation,
1226      $self->cfg,
1227      ARTICLE_CUSTOM_FIELDS_CFG,
1228      BSE::DB->single->dbh,
1229     );
1230 }
1231
1232 sub _custom_fields {
1233   my $self = shift;
1234
1235   my $fields = $self->custom_fields;
1236   my %active;
1237   for my $key (keys %$fields) {
1238     $fields->{$key}{description}
1239       and $active{$key} = $fields->{$key};
1240   }
1241
1242   return \%active;
1243 }
1244
1245 =back
1246
1247 =head1 Common Edit Page Tags
1248
1249 Variables:
1250
1251 =over
1252
1253 =item *
1254
1255 C<article> - the article being edited.  This is a dummy article when a
1256 new article is being created.
1257
1258 =item *
1259
1260 C<isnew> - true if a new article is being created.
1261
1262 =item *
1263
1264 C<custom> - describes custom tags.
1265
1266 =item *
1267
1268 C<errors> - errors from the last submission of the page.
1269
1270 =item *
1271
1272 C<image_stores> - a function returning an array of possible image
1273 storages.
1274
1275 =item *
1276
1277 C<thumbs> - for the image list, whether thumbs should be displayed
1278 instead of full size images.
1279
1280 =item *
1281
1282 C<can_thumbs> - true if thumbnails are available.
1283
1284 =back
1285
1286 =cut
1287
1288 sub low_edit_tags {
1289   my ($self, $acts, $request, $article, $articles, $msg, $errors) = @_;
1290
1291   my $cgi = $request->cgi;
1292   my $show_full = $cgi->param('f_showfull');
1293   my $if_error = $msg || ($errors && keys %$errors) || $request->cgi->param("_e");
1294   #$msg ||= join "\n", map escape_html($_), $cgi->param('message'), $cgi->param('m');
1295   $msg .= $request->message($errors);
1296   my $parent;
1297   if ($article->{id}) {
1298     if ($article->{parentid} > 0) {
1299       $parent = $article->parent;
1300     }
1301     else {
1302       $parent = { title=>"No parent - this is a section", id=>-1 };
1303     }
1304   }
1305   else {
1306     $parent = { title=>"How did we get here?", id=>0 };
1307   }
1308   $request->set_article(article => $article);
1309   $request->set_variable(ifnew => !$article->{id});
1310   my $cfg = $self->{cfg};
1311   my $mbcs = $cfg->entry('html', 'mbcs', 0);
1312   my $tag_hash = $mbcs ? \&tag_hash_mbcs : \&tag_hash;
1313   my $thumbs_obj_real = $self->_get_thumbs_class();
1314   my $thumbs_obj = $show_full ? undef : $thumbs_obj_real;
1315   my @images;
1316   my $image_index;
1317   my $current_image;
1318   my @children;
1319   my $child_index;
1320   my %stepkids;
1321   my @allkids;
1322   my $allkid_index;
1323   my @possstepkids;
1324   my @stepparents;
1325   my $stepparent_index;
1326   my @stepparent_targs;
1327   my @stepparentpossibles;
1328   my @files;
1329   my $file_index;
1330   my @groups;
1331   my $current_group;
1332   my $it = BSE::Util::Iterate->new;
1333   my $ito = BSE::Util::Iterate::Objects->new;
1334   my $ita = BSE::Util::Iterate::Article->new(req => $request);
1335
1336   my $custom = $self->_custom_fields;
1337   # only return the fields that are defined
1338   $request->set_variable(custom => $custom);
1339   $request->set_variable(errors => $errors || {});
1340   my $article_type = $cfg->entry('level names', $article->{level}, 'Article');
1341   $request->set_variable(article_type => $article_type);
1342   $request->set_variable(thumbs => defined $thumbs_obj);
1343   $request->set_variable(can_thumbs => defined $thumbs_obj_real);
1344   $request->set_variable(image_stores =>
1345                          sub {
1346                            $self->iter_image_stores;
1347                          });
1348
1349   return
1350     (
1351      $request->admin_tags,
1352      article => sub { tag_article($article, $cfg, $_[0]) },
1353      old => [ \&tag_old, $article, $cgi ],
1354      default => [ \&tag_default, $self, $request, $article ],
1355      articleType => escape_html($article_type),
1356      parentType => [ \&tag_art_type, $article->{level}-1, $cfg ],
1357      ifNew => [ \&tag_if_new, $article ],
1358      list => [ \&tag_list, $self, $article, $articles, $cgi, $request ],
1359      script => $ENV{SCRIPT_NAME},
1360      level => $article->{level},
1361      checked => \&tag_checked,
1362      $it->make_iterator
1363      ([ \&iter_get_images, $self, $article ], 'image', 'images', \@images,
1364       \$image_index, undef, \$current_image),
1365      image => [ tag_image => $self, $cfg, \$current_image ],
1366      thumbimage => [ \&tag_thumbimage, $cfg, $thumbs_obj, \$current_image ],
1367      ifThumbs => defined($thumbs_obj),
1368      ifCanThumbs => defined($thumbs_obj_real),
1369      imgmove => [ \&tag_imgmove, $request, $article, \$image_index, \@images ],
1370      message => $msg,
1371      ifError => $if_error,
1372      $ita->make
1373      (
1374       code => [ \&iter_get_kids, $article, $articles ],
1375       single => 'child',
1376       plural => 'children',
1377       data => \@children,
1378       index => \$child_index,
1379      ),
1380      ifchildren => \&tag_if_children,
1381      childtype => [ \&tag_art_type, $article->{level}+1, $cfg ],
1382      ifHaveChildType => [ \&tag_if_have_child_type, $article->{level}, $cfg ],
1383      movechild => [ \&tag_movechild, $self, $request, $article, \@children,
1384                     \$child_index],
1385      is => \&tag_is,
1386      templates => [ \&tag_templates, $self, $article, $cfg, $cgi ],
1387      titleImages => [ \&tag_title_images, $self, $article, $cfg, $cgi ],
1388      editParent => [ \&tag_edit_parent, $article ],
1389      $ita->make
1390      (
1391       code => [ \&iter_allkids, $article ],
1392       single => 'kid',
1393       plural => 'kids',
1394       data => \@allkids,
1395       index => \$allkid_index,
1396      ),
1397      ifStepKid =>
1398      [ \&tag_if_step_kid, $article, \@allkids, \$allkid_index, \%stepkids ],
1399      stepkid => [ \&tag_step_kid, $article, \@allkids, \$allkid_index,
1400                   \%stepkids ],
1401      movestepkid =>
1402      [ \&tag_move_stepkid, $self, $cgi, $request, $article, \@allkids,
1403        \$allkid_index ],
1404      possible_stepkids =>
1405      [ \&tag_possible_stepkids, \%stepkids, $request, $article,
1406        \@possstepkids, $articles, $cgi ],
1407      ifPossibles =>
1408      [ \&tag_if_possible_stepkids, \%stepkids, $request, $article,
1409        \@possstepkids, $articles, $cgi ],
1410      $ita->make
1411      (
1412       code => [ \&iter_get_stepparents, $article ],
1413       single => 'stepparent',
1414       plural => 'stepparents',
1415       data => \@stepparents,
1416       index => \$stepparent_index,
1417      ),
1418      ifStepParents => \&tag_ifStepParents,
1419      stepparent_targ =>
1420      [ \&tag_stepparent_targ, $article, \@stepparent_targs,
1421        \$stepparent_index ],
1422      movestepparent =>
1423      [ \&tag_move_stepparent, $self, $cgi, $request, $article, \@stepparents,
1424        \$stepparent_index ],
1425      ifStepparentPossibles =>
1426      [ \&tag_if_stepparent_possibles, $request, $article, $articles,
1427        \@stepparent_targs, \@stepparentpossibles, ],
1428      stepparent_possibles =>
1429      [ \&tag_stepparent_possibles, $cgi, $request, $article, $articles,
1430        \@stepparent_targs, \@stepparentpossibles, ],
1431      $ito->make
1432      (
1433       code => [ iter_files => $self, $article ],
1434       single => 'file',
1435       plural => 'files',
1436       data => \@files,
1437       index => \$file_index,
1438      ),
1439      movefiles =>
1440      [ \&tag_movefiles, $self, $request, $article, \@files, \$file_index ],
1441      $it->make
1442      (
1443       code => [ iter_file_metas => $self, \@files, \$file_index ],
1444       plural => "file_metas",
1445       single => "file_meta",
1446       nocache => 1,
1447      ),
1448      ifFileExists => sub {
1449        @files && $file_index >= 0 && $file_index < @files
1450          or return 0;
1451
1452        return -f ($files[$file_index]->full_filename($cfg));
1453      },
1454      file_display => [ tag_file_display => $self, \@files, \$file_index ],
1455      DevHelp::Tags->make_iterator2
1456      (\&iter_admin_users, 'iadminuser', 'adminusers'),
1457      DevHelp::Tags->make_iterator2
1458      (\&iter_admin_groups, 'iadmingroup', 'admingroups'),
1459      edit => [ \&tag_edit_link, $cfg, $article ],
1460      error => [ $tag_hash, $errors ],
1461      error_img => [ \&tag_error_img, $cfg, $errors ],
1462      ifFieldPerm => [ \&tag_if_field_perm, $request, $article ],
1463      parent => [ \&tag_article, $parent, $cfg ],
1464      DevHelp::Tags->make_iterator2
1465      ([ \&iter_flags, $self ], 'flag', 'flags' ),
1466      ifFlagSet => [ \&tag_if_flag_set, $article ],
1467      DevHelp::Tags->make_iterator2
1468      ([ \&iter_crumbs, $article, $articles ], 'crumb', 'crumbs' ),
1469      typename => \&tag_typename,
1470      $it->make_iterator([ \&iter_groups, $request ],
1471                         'group', 'groups', \@groups, undef, undef,
1472                         \$current_group),
1473      $it->make_iterator([ iter_image_stores => $self],
1474                         'image_store', 'image_stores'),
1475      $it->make_iterator([ iter_file_stores => $self],
1476                         'file_store', 'file_stores'),
1477      ifGroupRequired => [ \&tag_ifGroupRequired, $article, \$current_group ],
1478      category => [ tag_category => $self, $articles, $article ],
1479      $ito->make
1480      (
1481       single => "tag",
1482       plural => "tags",
1483       code => [ iter_tags => $self, $article ],
1484      ),
1485     );
1486 }
1487
1488 sub iter_image_stores {
1489   my ($self) = @_;
1490
1491   my $mgr = $self->_image_manager;
1492
1493   return map +{ name => $_->name, description => $_->description },
1494     $mgr->all_stores;
1495 }
1496
1497 sub _file_manager {
1498   my ($self) = @_;
1499
1500   require BSE::TB::ArticleFiles;
1501
1502   return BSE::TB::ArticleFiles->file_manager($self->cfg);
1503 }
1504
1505 sub iter_file_stores {
1506   my ($self) = @_;
1507
1508   require BSE::TB::ArticleFiles;
1509   my $mgr = $self->_file_manager($self->cfg);
1510
1511   return map +{ name => $_->name, description => $_->description },
1512     $mgr->all_stores;
1513 }
1514
1515 sub iter_groups {
1516   my ($req) = @_;
1517
1518   require BSE::TB::SiteUserGroups;
1519   BSE::TB::SiteUserGroups->admin_and_query_groups($req->cfg);
1520 }
1521
1522 sub tag_ifGroupRequired {
1523   my ($article, $rgroup) = @_;
1524
1525   $article->{id}
1526     or return 0;
1527
1528   $$rgroup or return 0;
1529
1530   $article->is_accessible_to($$rgroup);
1531 }
1532
1533 sub edit_template {
1534   my ($self, $article, $cgi) = @_;
1535
1536   my $base = $article->{level};
1537   my $t = $cgi->param('_t');
1538   if ($t && $t =~ /^\w+$/) {
1539     $base = $t;
1540   }
1541   return $self->{cfg}->entry('admin templates', $base,
1542                              "admin/edit_$base");
1543 }
1544
1545 sub add_template {
1546   my ($self, $article, $cgi) = @_;
1547
1548   $self->edit_template($article, $cgi);
1549 }
1550
1551 sub low_edit_form {
1552   my ($self, $request, $article, $articles, $msg, $errors) = @_;
1553
1554   my $cgi = $request->cgi;
1555   my %acts;
1556   %acts = $self->low_edit_tags(\%acts, $request, $article, $articles, $msg,
1557                               $errors);
1558   my $template = $article->{id} ?
1559     $self->edit_template($article, $cgi) : $self->add_template($article, $cgi);
1560
1561   return $request->response($template, \%acts);
1562 }
1563
1564 sub edit_form {
1565   my ($self, $request, $article, $articles, $msg, $errors) = @_;
1566
1567   return $self->low_edit_form($request, $article, $articles, $msg, $errors);
1568 }
1569
1570 sub _dummy_article {
1571   my ($self, $req, $articles, $rmsg) = @_;
1572
1573   my $level;
1574   my $cgi = $req->cgi;
1575   my $parentid = $cgi->param('parentid');
1576   if ($parentid) {
1577     if ($parentid =~ /^\d+$/) {
1578       if (my $parent = $self->get_parent($parentid, $articles)) {
1579         $level = $parent->{level}+1;
1580       }
1581       else {
1582         $parentid = undef;
1583       }
1584     }
1585     elsif ($parentid eq "-1") {
1586       $level = 1;
1587     }
1588   }
1589   unless (defined $level) {
1590     $level = $cgi->param('level');
1591     undef $level unless defined $level && $level =~ /^\d+$/
1592       && $level > 0 && $level < 100;
1593     defined $level or $level = 3;
1594   }
1595
1596   my %article;
1597   my @cols = BSE::TB::Article->columns;
1598   @article{@cols} = ('') x @cols;
1599   $article{id} = '';
1600   $article{parentid} = $parentid;
1601   $article{level} = $level;
1602   $article{body} = '<maximum of 64Kb>';
1603   $article{listed} = 1;
1604   $article{generator} = $self->generator;
1605
1606   my ($values, $labels) = $self->possible_parents(\%article, $articles, $req);
1607   unless (@$values) {
1608     $$rmsg = "You can't add children to any article at that level";
1609     return;
1610   }
1611
1612   return $self->_make_dummy_article(\%article);
1613 }
1614
1615 sub _make_dummy_article {
1616   my ($self, $article) = @_;
1617
1618   require BSE::DummyArticle;
1619   return bless $article, "BSE::DummyArticle";
1620 }
1621
1622 sub add_form {
1623   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1624
1625   return $self->low_edit_form($req, $article, $articles, $msg, $errors);
1626 }
1627
1628 sub generator { 'BSE::Generate::Article' }
1629
1630 sub typename {
1631   my ($self) = @_;
1632
1633   my $gen = $self->generator;
1634
1635   ($gen =~ /(\w+)$/)[0] || 'Article';
1636 }
1637
1638 sub _validate_common {
1639   my ($self, $data, $articles, $errors, $article) = @_;
1640
1641 #   if (defined $data->{parentid} && $data->{parentid} =~ /^(?:-1|\d+)$/) {
1642 #     unless ($data->{parentid} == -1 or
1643 #           $articles->getByPkey($data->{parentid})) {
1644 #       $errors->{parentid} = "Selected parent article doesn't exist";
1645 #     }
1646 #   }
1647 #   else {
1648 #     $errors->{parentid} = "You need to select a valid parent";
1649 #   }
1650   if (exists $data->{title} && $data->{title} !~ /\S/) {
1651     $errors->{title} = "Please enter a title";
1652   }
1653
1654   if (exists $data->{template} && $data->{template} =~ /\.\./) {
1655     $errors->{template} = "Please only select templates from the list provided";
1656   }
1657   if (exists $data->{linkAlias}
1658       && length $data->{linkAlias}) {
1659     unless ($data->{linkAlias} =~ /\A[a-zA-Z0-9-_]+\z/
1660             && $data->{linkAlias} =~ /[A-Za-z]/) {
1661       $errors->{linkAlias} = "Link alias must contain only alphanumerics and contain at least one letter";
1662     }
1663   }
1664
1665   if (defined $data->{category}) {
1666     unless (first { $_->{id} eq $data->{category} } $self->categories($articles)) {
1667       $errors->{category} = "msg:bse/admin/edit/category/unknown";
1668     }
1669   }
1670
1671   require DevHelp::Validate;
1672   DevHelp::Validate->import('dh_validate_hash');
1673   dh_validate_hash($data, $errors,
1674                    {
1675                     fields => $self->_custom_fields,
1676                     optional => 1,
1677                     dbh => BSE::DB->single->dbh,
1678                    },
1679                    $self->cfg, ARTICLE_CUSTOM_FIELDS_CFG);
1680 }
1681
1682 sub validate {
1683   my ($self, $data, $articles, $errors) = @_;
1684
1685   $self->_validate_common($data, $articles, $errors);
1686   if (!$errors->{linkAlias} && defined $data->{linkAlias} && length $data->{linkAlias}) {
1687     my $other = $articles->getBy(linkAlias => $data->{linkAlias});
1688     $other
1689       and $errors->{linkAlias} =
1690         "Duplicate link alias - already used by article $other->{id}";
1691   }
1692   custom_class($self->{cfg})
1693     ->article_validate($data, undef, $self->typename, $errors);
1694
1695   return !keys %$errors;
1696 }
1697
1698 sub validate_old {
1699   my ($self, $article, $data, $articles, $errors, $ajax) = @_;
1700
1701   $self->_validate_common($data, $articles, $errors, $article);
1702   custom_class($self->{cfg})
1703     ->article_validate($data, $article, $self->typename, $errors);
1704
1705   if (exists $data->{release}) {
1706     if ($ajax && !dh_parse_sql_date($data->{release})
1707         || !$ajax && !dh_parse_date($data->{release})) {
1708       $errors->{release} = "Invalid release date";
1709     }
1710   }
1711
1712   if (!$errors->{linkAlias}
1713       && defined $data->{linkAlias}
1714       && length $data->{linkAlias}
1715       && $data->{linkAlias} ne $article->{linkAlias}) {
1716     my $other = $articles->getBy(linkAlias => $data->{linkAlias});
1717     $other && $other->{id} != $article->{id}
1718       and $errors->{linkAlias} = "Duplicate link alias - already used by article $other->{id}";
1719   }
1720
1721   return !keys %$errors;
1722 }
1723
1724 sub validate_parent {
1725   1;
1726 }
1727
1728 sub fill_new_data {
1729   my ($self, $req, $data, $articles) = @_;
1730
1731   my $custom = $self->_custom_fields;
1732   for my $key (keys %$custom) {
1733     my ($value) = $req->cgi->param($key);
1734     if (defined $value) {
1735       if ($key =~ /^customDate/) {
1736         require DevHelp::Date;
1737         my $msg;
1738         if (my ($year, $month, $day) =
1739             DevHelp::Date::dh_parse_date($value, \$msg)) {
1740           $data->{$key} = sprintf("%04d-%02d-%02d", $year, $month, $day);
1741         }
1742         else {
1743           $data->{$key} = undef;
1744         }
1745       }
1746       elsif ($key =~ /^customInt/) {
1747         if ($value =~ /\S/) {
1748           $data->{$key} = $value;
1749         }
1750         else {
1751           $data->{$key} = undef;
1752         }
1753       }
1754       else {
1755         $data->{$key} = $value;
1756       }
1757     }
1758   }
1759
1760   custom_class($self->{cfg})
1761     ->article_fill_new($data, $self->typename);
1762
1763   1;
1764 }
1765
1766 sub link_path {
1767   my ($self, $article) = @_;
1768
1769   # check the config for the article and any of its ancestors
1770   my $work_article = $article;
1771   my $path = $self->{cfg}->entry('article uris', $work_article->{id});
1772   while (!$path) {
1773     last if $work_article->{parentid} == -1;
1774     $work_article = $work_article->parent;
1775     $path = $self->{cfg}->entry('article uris', $work_article->{id});
1776   }
1777   return $path if $path;
1778
1779   $self->default_link_path($article);
1780 }
1781
1782 sub default_link_path {
1783   my ($self, $article) = @_;
1784
1785   $self->{cfg}->entry('uri', 'articles', '/a');
1786 }
1787
1788 sub make_link {
1789   my ($self, $article) = @_;
1790
1791   $article->is_linked
1792     or return "";
1793
1794   my $title = $article->title;
1795   if ($article->is_dynamic) {
1796     (my $extra = $title) =~ tr/A-Za-z0-9/-/sc;
1797     return "/cgi-bin/page.pl?page=$article->{id}&title=".escape_uri($extra);
1798   }
1799
1800   my $article_uri = $self->link_path($article);
1801   my $link = "$article_uri/$article->{id}.html";
1802   my $link_titles = $self->{cfg}->entryBool('basic', 'link_titles', 0);
1803   if ($link_titles) {
1804     (my $extra = $title) =~ tr/A-Za-z0-9/-/sc;
1805     $link .= "/" . $extra . "_html";
1806   }
1807
1808   $link;
1809 }
1810
1811 sub save_columns {
1812   my ($self, $table_object) = @_;
1813
1814   my @columns = $table_object->rowClass->columns;
1815   shift @columns;
1816
1817   return @columns;
1818 }
1819
1820 sub _validate_tags {
1821   my ($self, $tags, $errors) = @_;
1822
1823   my $fail = 0;
1824   my @errors;
1825   for my $tag (@$tags) {
1826     my $error;
1827     if ($tag =~ /\S/
1828         && !BSE::TB::Tags->valid_name($tag, \$error)) {
1829       push @errors, "msg:bse/admin/edit/tags/invalid/$error";
1830       $errors->{tags} = \@errors;
1831       ++$fail;
1832     }
1833     else {
1834       push @errors, undef;
1835     }
1836   }
1837
1838   return $fail;
1839 }
1840
1841 sub save_new {
1842   my ($self, $req, $article, $articles) = @_;
1843
1844   $req->check_csrf("admin_add_article")
1845     or return $self->csrf_error($req, undef, "admin_add_article", "Add Article");
1846
1847   my $cgi = $req->cgi;
1848   my %data;
1849   my $table_object = $self->table_object($articles);
1850   my @columns = $self->save_columns($table_object);
1851   $self->save_thumbnail($cgi, undef, \%data);
1852   for my $name (@columns) {
1853     $data{$name} = $cgi->param($name)
1854       if defined $cgi->param($name);
1855   }
1856   $data{flags} = join '', sort $cgi->param('flags');
1857
1858   my $msg;
1859   my %errors;
1860   if (!defined $data{parentid} || $data{parentid} eq '') {
1861     $errors{parentid} = "Please select a parent";
1862   }
1863   elsif ($data{parentid} !~ /^(?:-1|\d+)$/) {
1864     $errors{parentid} = "Invalid parent selection (template bug)";
1865   }
1866   $self->validate(\%data, $articles, \%errors);
1867
1868   my $save_tags = $cgi->param("_save_tags");
1869   my @tags;
1870   if ($save_tags) {
1871     @tags = $cgi->param("tags");
1872     $self->_validate_tags(\@tags, \%errors);
1873   }
1874
1875   my $meta;
1876   if ($cgi->param("_save_meta")) {
1877     require BSE::ArticleMetaMeta;
1878     $meta = BSE::ArticleMetaMeta->retrieve($req, $article, \%errors);
1879   }
1880
1881   if (keys %errors) {
1882     if ($req->is_ajax) {
1883       return $req->json_content
1884         (
1885          success => 0,
1886          errors => \%errors,
1887          error_code => "FIELD",
1888          message => $req->message(\%errors),
1889         );
1890     }
1891     else {
1892       return $self->add_form($req, $article, $articles, $msg, \%errors);
1893     }
1894   }
1895
1896   my $parent;
1897   my $parent_msg;
1898   my $parent_code;
1899   if ($data{parentid} > 0) {
1900     $parent = $articles->getByPkey($data{parentid}) or die;
1901     if ($req->user_can('edit_add_child', $parent)) {
1902       for my $name (@columns) {
1903         if (exists $data{$name} &&
1904             !$req->user_can("edit_add_field_$name", $parent)) {
1905           delete $data{$name};
1906         }
1907       }
1908     }
1909     else {
1910       $parent_msg = "You cannot add a child to that article";
1911       $parent_code = "ACCESS";
1912     }
1913   }
1914   else {
1915     if ($req->user_can('edit_add_child')) {
1916       for my $name (@columns) {
1917         if (exists $data{$name} &&
1918             !$req->user_can("edit_add_field_$name")) {
1919           delete $data{$name};
1920         }
1921       }
1922     }
1923     else {
1924       $parent_msg = "You cannot create a top-level article";
1925       $parent_code = "ACCESS";
1926     }
1927   }
1928   if (!$parent_msg) {
1929     $self->validate_parent(\%data, $articles, $parent, \$parent_msg)
1930       or $parent_code = "PARENT";
1931   }
1932   if ($parent_msg) {
1933     if ($req->is_ajax) {
1934       return $req->json_content
1935         (
1936          success => 0,
1937          message => $parent_msg,
1938          error_code => $parent_code,
1939          errors => {},
1940         );
1941     }
1942     else {
1943       return $self->add_form($req, $article, $articles, $parent_msg);
1944     }
1945   }
1946
1947   my $level = $parent ? $parent->{level}+1 : 1;
1948   $data{level} = $level;
1949   $data{displayOrder} = time;
1950   $data{link} ||= '';
1951   $data{admin} ||= '';
1952   $data{generator} = $self->generator;
1953   $data{lastModified} = now_sqldatetime();
1954   $data{listed} = 1 unless defined $data{listed};
1955
1956 # Added by adrian
1957   $data{pageTitle} = '' unless defined $data{pageTitle};
1958   my $user = $req->getuser;
1959   $data{createdBy} = $user ? $user->{logon} : '';
1960   $data{lastModifiedBy} = $user ? $user->{logon} : '';
1961   $data{created} =  now_sqldatetime();
1962 # end adrian
1963
1964   $data{force_dynamic} = 0;
1965   $data{cached_dynamic} = 0;
1966   $data{inherit_siteuser_rights} = 1;
1967
1968 # Added by adrian
1969   $data{metaDescription} = '' unless defined $data{metaDescription};
1970   $data{metaKeywords} = '' unless defined $data{metaKeywords};
1971 # end adrian
1972
1973   $self->fill_new_data($req, \%data, $articles);
1974   for my $col (qw(titleImage imagePos template keyword menu titleAlias linkAlias body author summary category)) {
1975     defined $data{$col}
1976       or $data{$col} = $self->default_value($req, \%data, $col);
1977   }
1978
1979   for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1980     if ($req->user_can("edit_add_field_$col", $parent)
1981         && $cgi->param("save_$col")) {
1982       $data{$col} = $cgi->param($col) ? 1 : 0;
1983     }
1984     else {
1985       $data{$col} = $self->default_value($req, \%data, $col);
1986     }
1987   }
1988
1989   unless ($req->is_ajax) {
1990     for my $col (qw(release expire)) {
1991       $data{$col} = sql_date($data{$col});
1992     }
1993   }
1994
1995   # these columns are handled a little differently
1996   for my $col (qw(release expire threshold summaryLength )) {
1997     $data{$col}
1998       or $data{$col} = $self->default_value($req, \%data, $col);
1999   }
2000
2001   my @cols = $table_object->rowClass->columns;
2002   shift @cols;
2003
2004   # fill out anything else from defaults
2005   for my $col (@columns) {
2006     exists $data{$col}
2007       or $data{$col} = $self->default_value($req, \%data, $col);
2008   }
2009
2010   $article = $table_object->add(@data{@cols});
2011
2012   $self->save_new_more($req, $article, \%data);
2013
2014   # we now have an id - generate the links
2015
2016   $article->update_dynamic($self->{cfg});
2017   my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
2018   $article->setAdmin("$cgi_uri/admin/admin.pl?id=$article->{id}");
2019   $article->setLink($self->make_link($article));
2020   $article->save();
2021
2022   my ($after_id) = $cgi->param("_after");
2023   if (defined $after_id) {
2024     BSE::TB::Articles->reorder_child($article->{parentid}, $article->{id}, $after_id);
2025     # reload, the displayOrder probably changed
2026     $article = $articles->getByPkey($article->{id});
2027   }
2028
2029   if ($save_tags) {
2030     my $error;
2031     $article->set_tags([ grep /\S/, @tags ], \$error);
2032   }
2033
2034   if ($meta) {
2035     BSE::ArticleMetaMeta->save($article, $meta);
2036   }
2037
2038   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2039
2040   if ($req->is_ajax) {
2041     return $req->json_content
2042       (
2043        {
2044         success => 1,
2045         article => $self->_article_data($req, $article),
2046        },
2047       );
2048   }
2049
2050   my $r = $cgi->param('r');
2051   if ($r) {
2052     $r .= ($r =~ /\?/) ? '&' : '?';
2053     $r .= "id=$article->{id}";
2054   }
2055   else {
2056     $r = admin_base_url($req->cfg) . $article->{admin};
2057   }
2058   return BSE::Template->get_refresh($r, $self->{cfg});
2059 }
2060
2061 sub fill_old_data {
2062   my ($self, $req, $article, $data) = @_;
2063
2064   if (exists $data->{body}) {
2065     $data->{body} =~ s/\x0D\x0A/\n/g;
2066     $data->{body} =~ tr/\r/\n/;
2067   }
2068   for my $col (BSE::TB::Article->columns) {
2069     next if $col =~ /^custom/;
2070     $article->{$col} = $data->{$col}
2071       if exists $data->{$col} && $col ne 'id' && $col ne 'parentid';
2072   }
2073   my $custom = $self->_custom_fields;
2074   for my $key (keys %$custom) {
2075     if (exists $data->{$key}) {
2076       if ($key =~ /^customDate/) {
2077         require DevHelp::Date;
2078         my $msg;
2079         if (my ($year, $month, $day) =
2080             DevHelp::Date::dh_parse_date($data->{$key}, \$msg)) {
2081           $article->set($key, sprintf("%04d-%02d-%02d", $year, $month, $day));
2082         }
2083         else {
2084           $article->set($key => undef);
2085         }
2086       }
2087       elsif ($key =~ /^customInt/) {
2088         if ($data->{$key} =~ /\S/) {
2089           $article->set($key => $data->{$key});
2090         }
2091         else {
2092           $article->set($key => undef);
2093         }
2094       }
2095       else {
2096         $article->set($key => $data->{$key});
2097       }
2098     }
2099   }
2100   custom_class($self->{cfg})
2101     ->article_fill_old($article, $data, $self->typename);
2102
2103   return 1;
2104 }
2105
2106 sub _article_data {
2107   my ($self, $req, $article) = @_;
2108
2109   my $article_data = $article->data_only;
2110   $article_data->{link} = $article->link($req->cfg);
2111   $article_data->{images} =
2112     [
2113      map $self->_image_data($req->cfg, $_), $article->images
2114     ];
2115   $article_data->{files} =
2116     [
2117      map $_->data_only, $article->files,
2118     ];
2119   $article_data->{tags} =
2120     [
2121      $article->tags, # just the names
2122     ];
2123
2124   return $article_data;
2125 }
2126
2127 sub save_more {
2128   my ($self, $req, $article, $data) = @_;
2129   # nothing to do here
2130 }
2131
2132 sub save_new_more {
2133   my ($self, $req, $article, $data) = @_;
2134   # nothing to do here
2135 }
2136
2137 =over
2138
2139 =item save
2140
2141 Error codes:
2142
2143 =over
2144
2145 =item *
2146
2147 ACCESS - user doesn't have access to this article.
2148
2149 =item *
2150
2151 LASTMOD - lastModified value doesn't match that in the article
2152
2153 =item *
2154
2155 PARENT - invalid parentid specified
2156
2157 =back
2158
2159 =cut
2160
2161 sub save {
2162   my ($self, $req, $article, $articles) = @_;
2163
2164   $req->check_csrf("admin_save_article")
2165     or return $self->csrf_error($req, $article, "admin_save_article", "Save Article");
2166
2167   $req->user_can(edit_save => $article)
2168     or return $self->_service_error
2169       ($req, $article, $articles, "You don't have access to save this article",
2170        {}, "ACCESS");
2171
2172   my $old_dynamic = $article->is_dynamic;
2173   my $cgi = $req->cgi;
2174   my %data;
2175   my $table_object = $self->table_object($articles);
2176   my @save_cols = $self->save_columns($table_object);
2177   for my $name (@save_cols) {
2178     $data{$name} = $cgi->param($name)
2179       if defined($cgi->param($name)) and $name ne 'id' && $name ne 'parentid'
2180         && $req->user_can("edit_field_edit_$name", $article);
2181   }
2182
2183 # Added by adrian
2184 # checks editor lastModified against record lastModified
2185   if ($self->{cfg}->entry('editor', 'check_modified')) {
2186     if ($article->{lastModified} ne $cgi->param('lastModified')) {
2187       my $whoModified = '';
2188       my $timeModified = ampm_time($article->{lastModified});
2189       if ($article->{lastModifiedBy}) {
2190         $whoModified = "by '$article->{lastModifiedBy}'";
2191       }
2192       print STDERR "non-matching lastModified, article not saved\n";
2193       my $msg = "Article changes not saved, this article was modified $whoModified at $timeModified since this editor was loaded";
2194       return $self->_service_error($req, $article, $articles, $msg, {}, "LASTMOD");
2195     }
2196   }
2197 # end adrian
2198
2199   # possibly this needs tighter error checking
2200   $data{flags} = join '', sort $cgi->param('flags')
2201     if $req->user_can("edit_field_edit_flags", $article);
2202   my %errors;
2203   if (exists $article->{template} &&
2204       $article->{template} =~ m|\.\.|) {
2205     $errors{template} = "Please only select templates from the list provided";
2206   }
2207
2208   my $meta;
2209   if ($cgi->param("_save_meta")) {
2210     require BSE::ArticleMetaMeta;
2211     $meta = BSE::ArticleMetaMeta->retrieve($req, $article, \%errors);
2212   }
2213
2214   my $save_tags = $cgi->param("_save_tags");
2215   my @tags;
2216   if ($save_tags) {
2217     @tags = $cgi->param("tags");
2218     $self->_validate_tags(\@tags, \%errors);
2219   }
2220   $self->validate_old($article, \%data, $articles, \%errors, scalar $req->is_ajax)
2221     or return $self->_service_error($req, $article, $articles, undef, \%errors, "FIELD");
2222   $self->save_thumbnail($cgi, $article, \%data)
2223     if $req->user_can('edit_field_edit_thumbImage', $article);
2224   if (exists $data{flags} && $data{flags} =~ /D/) {
2225     $article->remove_html;
2226   }
2227   $self->fill_old_data($req, $article, \%data);
2228
2229   # reparenting
2230   my $newparentid = $cgi->param('parentid');
2231   if ($newparentid
2232       && $req->user_can('edit_field_edit_parentid', $article)
2233       && $newparentid != $article->{parentid}) {
2234     my $newparent;
2235     my $parent_editor;
2236     if ($newparentid == -1) {
2237       require BSE::Edit::Site;
2238       $newparent = BSE::TB::Site->new;
2239       $parent_editor = BSE::Edit::Site->new(cfg => $req->cfg);
2240     }
2241     else {
2242       $newparent = $articles->getByPkey($newparentid);
2243       ($parent_editor, $newparent) = $self->article_class($newparent, $articles, $req->cfg);
2244     }
2245     if ($newparent) {
2246       my $msg;
2247       if ($self->can_reparent_to($article, $newparent, $parent_editor, $articles, \$msg)
2248          && $self->reparent($article, $newparentid, $articles, \$msg)) {
2249         # nothing to do here
2250       }
2251       else {
2252         return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
2253       }
2254     }
2255     else {
2256       return $self->_service_error($req, $article, $articles, "No such parent article", {}, "PARENT");
2257     }
2258   }
2259
2260   $article->{listed} = $cgi->param('listed')
2261    if defined $cgi->param('listed') &&
2262       $req->user_can('edit_field_edit_listed', $article);
2263
2264   if ($req->user_can('edit_field_edit_release', $article)) {
2265     my $release = $cgi->param("release");
2266     if (defined $release && $release =~ /\S/) {
2267       if ($req->is_ajax) {
2268         $article->{release} = $release;
2269       }
2270       else {
2271         $article->{release} = sql_date($release)
2272       }
2273     }
2274   }
2275
2276   $article->{expire} = sql_date($cgi->param('expire')) || $Constants::D_99
2277     if defined $cgi->param('expire') &&
2278       $req->user_can('edit_field_edit_expire', $article);
2279   for my $col (qw/force_dynamic inherit_siteuser_rights/) {
2280     if ($req->user_can("edit_field_edit_$col", $article)
2281         && $cgi->param("save_$col")) {
2282       $article->{$col} = $cgi->param($col) ? 1 : 0;
2283     }
2284   }
2285
2286   $article->mark_modified(actor => $req->getuser || "U");
2287
2288   my @save_group_ids = $cgi->param('save_group_id');
2289   if ($req->user_can('edit_field_edit_group_id')
2290       && @save_group_ids) {
2291     require BSE::TB::SiteUserGroups;
2292     my %groups = map { $_->{id} => $_ }
2293       BSE::TB::SiteUserGroups->admin_and_query_groups($self->{cfg});
2294     my %set = map { $_ => 1 } $cgi->param('group_id');
2295     my %current = map { $_ => 1 } $article->group_ids;
2296
2297     for my $group_id (@save_group_ids) {
2298       $groups{$group_id} or next;
2299       if ($current{$group_id} && !$set{$group_id}) {
2300         $article->remove_group_id($group_id);
2301       }
2302       elsif (!$current{$group_id} && $set{$group_id}) {
2303         $article->add_group_id($group_id);
2304       }
2305     }
2306   }
2307
2308   my $old_link = $article->{link};
2309   # this need to go last
2310   $article->update_dynamic($self->{cfg});
2311   if (!$self->{cfg}->entry('protect link', $article->{id})) {
2312     my $article_uri = $self->make_link($article);
2313     $article->setLink($article_uri);
2314   }
2315
2316   $article->save();
2317
2318   if ($save_tags) {
2319     my $error;
2320     $article->set_tags([ grep /\S/, @tags ], \$error);
2321   }
2322
2323 use Data::Dumper;
2324 print STDERR Dumper($meta);
2325   if ($meta) {
2326     BSE::ArticleMetaMeta->save($article, $meta);
2327   }
2328
2329   # fix the kids too
2330   my @extra_regen;
2331   @extra_regen = $self->update_child_dynamic($article, $articles, $req);
2332
2333   if ($article->is_dynamic || $old_dynamic) {
2334     if (!$old_dynamic and $old_link) {
2335       unlink $article->link_to_filename($self->{cfg}, $old_link);
2336     }
2337     elsif (!$article->is_dynamic) {
2338       unlink $article->cached_filename($self->{cfg});
2339     }
2340   }
2341
2342   my ($after_id) = $cgi->param("_after");
2343   if (defined $after_id) {
2344     BSE::TB::Articles->reorder_child($article->{parentid}, $article->{id}, $after_id);
2345     # reload, the displayOrder probably changed
2346     $article = $articles->getByPkey($article->{id});
2347   }
2348
2349   if ($Constants::AUTO_GENERATE) {
2350     generate_article($articles, $article);
2351     for my $regen_id (@extra_regen) {
2352       my $regen = $articles->getByPkey($regen_id);
2353       BSE::Regen::generate_low($articles, $regen, $self->{cfg});
2354     }
2355   }
2356
2357   $self->save_more($req, $article, \%data);
2358
2359   if ($req->is_ajax) {
2360     return $req->json_content
2361       (
2362        {
2363         success => 1,
2364         article => $self->_article_data($req, $article),
2365        },
2366       );
2367   }
2368
2369   return $self->refresh($article, $cgi, undef, 'Article saved');
2370 }
2371
2372 sub can_reparent_to {
2373   my ($self, $article, $newparent, $parent_editor, $articles, $rmsg) = @_;
2374
2375   my @child_types = $parent_editor->child_types;
2376   if (!grep $_ eq ref $self, @child_types) {
2377     my ($child_type) = (ref $self) =~ /(\w+)$/;
2378     my ($parent_type) = (ref $parent_editor) =~ /(\w+)$/;
2379
2380     $$rmsg = "A $child_type cannot be a child of a $parent_type";
2381     return;
2382   }
2383
2384   # the article cannot become a child of itself or one of it's
2385   # children
2386   if ($article->{id} == $newparent->id
2387       || $self->is_descendant($article->id, $newparent->id, $articles)) {
2388     $$rmsg = "Cannot become a child of itself or of a descendant";
2389     return;
2390   }
2391
2392   my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2393   if ($self->shop_article) { # if this article belongs in the shop
2394     unless ($newparent->id == $shopid
2395             || $self->is_descendant($shopid, $newparent->{id}, $articles)) {
2396       $$rmsg = "This article belongs in the shop";
2397       return;
2398     }
2399   }
2400   else {
2401     if ($newparent->id == $shopid
2402         || $self->is_descendant($shopid, $newparent->id, $articles)) {
2403       $$rmsg = "This article doesn't belong in the shop";
2404       return;
2405     }
2406   }
2407
2408   return 1;
2409 }
2410
2411 sub shop_article { 0 }
2412
2413 sub update_child_dynamic {
2414   my ($self, $article, $articles, $req) = @_;
2415
2416   my $cfg = $req->cfg;
2417   my @stack = $article->children;
2418   my @regen;
2419   while (@stack) {
2420     my $workart = pop @stack;
2421     my $old_dynamic = $workart->is_dynamic; # before update
2422     my $old_link = $workart->{link};
2423     my $editor;
2424     ($editor, $workart) = $self->article_class($workart, $articles, $cfg);
2425
2426     $workart->update_dynamic($cfg);
2427     if ($old_dynamic != $workart->is_dynamic) {
2428       # update the link
2429       if ($article->{link} && !$cfg->entry('protect link', $workart->{id})) {
2430         my $uri = $editor->make_link($workart);
2431         $workart->setLink($uri);
2432
2433         !$old_dynamic && $old_link
2434           and unlink $workart->link_to_filename($cfg, $old_link);
2435         $workart->is_dynamic
2436           or unlink $workart->cached_filename($cfg);
2437       }
2438
2439       # save dynamic cache change and link if that changed
2440       $workart->save;
2441     }
2442     push @stack, $workart->children;
2443     push @regen, $workart->{id};
2444   }
2445
2446   @regen;
2447 }
2448
2449 sub sql_date {
2450   my $str = shift;
2451   my ($year, $month, $day);
2452
2453   # look for a date
2454   if (($day, $month, $year) = ($str =~ m!(\d+)/(\d+)/(\d+)!)) {
2455     $year += 2000 if $year < 100;
2456
2457     return sprintf("%04d-%02d-%02d", $year, $month, $day);
2458   }
2459   return undef;
2460 }
2461
2462 # Added by adrian
2463 # Converts 24hr time to 12hr AM/PM time
2464 sub ampm_time {
2465   my $str = shift;
2466   my ($hour, $minute, $second, $ampm);
2467
2468   # look for a time
2469   if (($hour, $minute, $second) = ($str =~ m!(\d+):(\d+):(\d+)!)) {
2470     if ($hour > 12) {
2471       $hour -= 12;
2472       $ampm = 'PM';
2473     }
2474     else {
2475       $hour = 12 if $hour == 0;
2476       $ampm = 'AM';
2477     }
2478     return sprintf("%02d:%02d:%02d $ampm", $hour, $minute, $second);
2479   }
2480   return undef;
2481 }
2482 # end adrian
2483
2484 sub reparent {
2485   my ($self, $article, $newparentid, $articles, $rmsg) = @_;
2486
2487   my $newlevel;
2488   if ($newparentid == -1) {
2489     $newlevel = 1;
2490   }
2491   else {
2492     my $parent = $articles->getByPkey($newparentid);
2493     unless ($parent) {
2494       $$rmsg = "Cannot get new parent article";
2495       return;
2496     }
2497     $newlevel = $parent->{level} + 1;
2498   }
2499   # the caller will save this one
2500   $article->{parentid} = $newparentid;
2501   $article->{level} = $newlevel;
2502   $article->{displayOrder} = time;
2503
2504   my @change = ( [ $article->{id}, $newlevel ] );
2505   while (@change) {
2506     my $this = shift @change;
2507     my ($art, $level) = @$this;
2508
2509     my @kids = $articles->getBy(parentid=>$art);
2510     push @change, map { [ $_->{id}, $level+1 ] } @kids;
2511
2512     for my $kid (@kids) {
2513       $kid->{level} = $level+1;
2514       $kid->save;
2515     }
2516   }
2517
2518   return 1;
2519 }
2520
2521 # tests if $desc is a descendant of $art
2522 # where both are article ids
2523 sub is_descendant {
2524   my ($self, $art, $desc, $articles) = @_;
2525
2526   my @check = ($art);
2527   while (@check) {
2528     my $parent = shift @check;
2529     $parent == $desc and return 1;
2530     my @kids = $articles->getBy(parentid=>$parent);
2531     push @check, map $_->{id}, @kids;
2532   }
2533
2534   return 0;
2535 }
2536
2537 sub save_thumbnail {
2538   my ($self, $cgi, $original, $newdata) = @_;
2539
2540   unless ($original) {
2541     @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2542   }
2543   my $imagedir = cfg_image_dir($self->{cfg});
2544   if ($cgi->param('remove_thumb') && $original && $original->{thumbImage}) {
2545     unlink("$imagedir/$original->{thumbImage}");
2546     @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2547   }
2548   my $image_name = $cgi->param('thumbnail');
2549   my $image = $cgi->upload('thumbnail');
2550   if ($image_name && -s $image) {
2551     # where to put it...
2552     my $name = '';
2553     $image_name =~ /([\w.-]+)$/ and $name = $1;
2554     my $filename = time . "_" . $name;
2555
2556     use Fcntl;
2557     my $counter = "";
2558     $filename = time . '_' . $counter . '_' . $name
2559       until sysopen( OUTPUT, "$imagedir/$filename",
2560                      O_WRONLY| O_CREAT| O_EXCL)
2561         || ++$counter > 100;
2562
2563     fileno(OUTPUT) or die "Could not open image file: $!";
2564     binmode OUTPUT;
2565     my $buffer;
2566
2567     #no strict 'refs';
2568
2569     # read the image in from the browser and output it to our
2570     # output filehandle
2571     print STDERR "\$image ",ref $image,"\n";
2572     seek $image, 0, 0;
2573     print OUTPUT $buffer while sysread $image, $buffer, 1024;
2574
2575     close OUTPUT
2576       or die "Could not close image output file: $!";
2577
2578     require BSE::ImageSize;
2579
2580     if ($original && $original->{thumbImage}) {
2581       #unlink("$imagedir/$original->{thumbImage}");
2582     }
2583     @$newdata{qw/thumbWidth thumbHeight/} =
2584       BSE::ImageSize::imgsize("$imagedir/$filename");
2585     $newdata->{thumbImage} = $filename;
2586   }
2587 }
2588
2589 sub child_types {
2590   my ($self, $article) = @_;
2591
2592   my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2593   if ($article && $article->{id} && $article->{id} == $shopid) {
2594     return ( 'BSE::Edit::Catalog' );
2595   }
2596   return ( 'BSE::Edit::Article' );
2597 }
2598
2599 =item add_stepkid
2600
2601 Add a step child to an article.
2602
2603 Parameters:
2604
2605 =over
2606
2607 =item *
2608
2609 id - parent article id (required)
2610
2611 =item *
2612
2613 stepkid - child article id (required)
2614
2615 =item *
2616
2617 _after - id of the allkid of id to position the stepkid after
2618 (optional)
2619
2620 =back
2621
2622 Returns a FIELD error for an invalid stepkid.
2623
2624 Returns an ACCESS error for insufficient access.
2625
2626 Return an ADD error for a general add failure.
2627
2628 On success returns:
2629
2630   {
2631    success: 1,
2632    relationship: { childId: I<childid>, parentId: I<parentid> }
2633   }
2634
2635 =back
2636
2637 =cut
2638
2639 sub add_stepkid {
2640   my ($self, $req, $article, $articles) = @_;
2641
2642   $req->check_csrf("admin_add_stepkid")
2643     or return $self->csrf_error($req, $article, "admin_add_stepkid", "Add Stepkid");
2644
2645   $req->user_can(edit_stepkid_add => $article)
2646     or return $self->_service_error($req, $article, $articles,
2647                                "You don't have access to add step children to this article", {}, "ACCESS");
2648
2649   my $cgi = $req->cgi;
2650   require BSE::Admin::StepParents;
2651
2652   my %errors;
2653   my $childId = $cgi->param('stepkid');
2654   defined $childId
2655     or $errors{stepkid} = "No stepkid supplied to add_stepkid";
2656   unless ($errors{stepkid}) {
2657     $childId =~ /^\d+$/
2658       or $errors{stepkid} = "Invalid stepkid supplied to add_stepkid";
2659   }
2660   my $child;
2661   unless ($errors{stepkid}) {
2662     $child = $articles->getByPkey($childId)
2663       or $errors{stepkid} = "Article $childId not found";
2664   }
2665   keys %errors
2666     and return $self->_service_error
2667       ($req, $article, $articles, $errors{stepkid}, \%errors, "FIELD");
2668
2669   $req->user_can(edit_stepparent_add => $child)
2670     or return $self->_service_error($req, $article, $articles, "You don't have access to add a stepparent to that article", {}, "ACCESS");
2671
2672   my $new_entry;
2673   eval {
2674
2675     my $release = $cgi->param('release');
2676     dh_parse_date($release) or $release = undef;
2677     my $expire = $cgi->param('expire');
2678     dh_parse_date($expire) or $expire = undef;
2679
2680     $new_entry =
2681       BSE::Admin::StepParents->add($article, $child, $release, $expire);
2682   };
2683   if ($@) {
2684     return $self->_service_error($req, $article, $articles, $@, {}, "ADD");
2685   }
2686
2687   my $after_id = $cgi->param("_after");
2688   if (defined $after_id) {
2689     BSE::TB::Articles->reorder_child($article->id, $child->id, $after_id);
2690   }
2691
2692   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2693
2694   if ($req->is_ajax) {
2695     return $req->json_content
2696       (
2697        success => 1,
2698        relationship => $new_entry->data_only,
2699       );
2700   }
2701   else {
2702     $self->refresh($article, $cgi, 'step', 'Stepchild added');
2703   }
2704 }
2705
2706 =item del_stepkid
2707
2708 Remove a stepkid relationship.
2709
2710 Parameters:
2711
2712 =over
2713
2714 =item *
2715
2716 id - parent article id (required)
2717
2718 =item *
2719
2720 stepkid - child article id (required)
2721
2722 =back
2723
2724 Returns a FIELD error for an invalid stepkid.
2725
2726 Returns an ACCESS error for insufficient access.
2727
2728 Return a DELETE error for a general delete failure.
2729
2730 =cut
2731
2732 sub del_stepkid {
2733   my ($self, $req, $article, $articles) = @_;
2734
2735   $req->check_csrf("admin_remove_stepkid")
2736     or return $self->csrf_error($req, $article, "admin_del_stepkid", "Delete Stepkid");
2737   $req->user_can(edit_stepkid_delete => $article)
2738     or return $self->_service_error($req, $article, $articles,
2739                                "You don't have access to delete stepchildren from this article", {}, "ACCESS");
2740
2741   my $cgi = $req->cgi;
2742
2743   my %errors;
2744   my $childId = $cgi->param('stepkid');
2745   defined $childId
2746     or $errors{stepkid} = "No stepkid supplied to add_stepkid";
2747   unless ($errors{stepkid}) {
2748     $childId =~ /^\d+$/
2749       or $errors{stepkid} = "Invalid stepkid supplied to add_stepkid";
2750   }
2751   my $child;
2752   unless ($errors{stepkid}) {
2753     $child = $articles->getByPkey($childId)
2754       or $errors{stepkid} = "Article $childId not found";
2755   }
2756   keys %errors
2757     and return $self->_service_error
2758       ($req, $article, $articles, $errors{stepkid}, \%errors, "FIELD");
2759
2760   $req->user_can(edit_stepparent_delete => $child)
2761     or return _service_error($req, $article, $article, "You cannot remove stepparents from that article", {}, "ACCESS");
2762
2763
2764   require BSE::Admin::StepParents;
2765   eval {
2766     BSE::Admin::StepParents->del($article, $child);
2767   };
2768
2769   if ($@) {
2770     return $self->_service_error($req, $article, $articles, $@, {}, "DELETE");
2771   }
2772   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2773
2774   if ($req->is_ajax) {
2775     return $req->json_content(success => 1);
2776   }
2777   else {
2778     return $self->refresh($article, $cgi, 'step', 'Stepchild deleted');
2779   }
2780 }
2781
2782 sub save_stepkids {
2783   my ($self, $req, $article, $articles) = @_;
2784
2785   $req->check_csrf("admin_save_stepkids")
2786     or return $self->csrf_error($req, $article, "admin_save_stepkids", "Save Stepkids");
2787
2788   $req->user_can(edit_stepkid_save => $article)
2789     or return $self->edit_form($req, $article, $articles,
2790                                "No access to save stepkid data for this article");
2791
2792   my $cgi = $req->cgi;
2793   require 'BSE/Admin/StepParents.pm';
2794   my @stepcats = BSE::TB::OtherParents->getBy(parentId=>$article->{id});
2795   my %stepcats = map { $_->{parentId}, $_ } @stepcats;
2796   my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2797   for my $stepcat (@stepcats) {
2798     $req->user_can(edit_stepparent_save => $stepcat->{childId})
2799       or next;
2800     for my $name (qw/release expire/) {
2801       my $date = $cgi->param($name.'_'.$stepcat->{childId});
2802       if (defined $date) {
2803         if ($date eq '') {
2804           $date = $datedefs{$name};
2805         }
2806         elsif (dh_parse_date($date)) {
2807           use BSE::Util::SQL qw/date_to_sql/;
2808           $date = date_to_sql($date);
2809         }
2810         else {
2811           return $self->refresh($article, $cgi, '', "Invalid date '$date'");
2812         }
2813         $stepcat->{$name} = $date;
2814       }
2815     }
2816     eval {
2817       $stepcat->save();
2818     };
2819     $@ and return $self->refresh($article, $cgi, '', $@);
2820   }
2821   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2822
2823   return $self->refresh($article, $cgi, 'step', 'Stepchild information saved');
2824 }
2825
2826 =item a_restepkid
2827
2828 Moves a stepkid from one parent to another, and sets the order within
2829 that new stepparent.
2830
2831 Parameters:
2832
2833 =over
2834
2835 =item *
2836
2837 id - id of the step kid to move (required)
2838
2839 =item *
2840
2841 parentid - id of the parent in the stepkid relationship (required)
2842
2843 =item *
2844
2845 newparentid - the new parent for the stepkid relationship (optional)
2846
2847 =item *
2848
2849 _after - id of the allkid under newparentid (or parentid if
2850 newparentid isn't supplied) to place the stepkid after (0 to place at
2851 the start)
2852
2853 =back
2854
2855 Errors:
2856
2857 =over
2858
2859 =item *
2860
2861 NOPARENTID - parentid parameter not supplied
2862
2863 =item *
2864
2865 BADPARENTID - non-numeric parentid supplied
2866
2867 =item *
2868
2869 NOTFOUND - no stepkid relationship from parentid was found
2870
2871 =item *
2872
2873 BADNEWPARENT - newparentid is non-numeric
2874
2875 =item *
2876
2877 UNKNOWNNEWPARENT - no article id newparentid found
2878
2879 =item *
2880
2881 NEWPARENTDUP - there's already a stepkid relationship between
2882 newparentid and id.
2883
2884 =back
2885
2886 =cut
2887
2888 sub req_restepkid {
2889   my ($self, $req, $article, $articles) = @_;
2890
2891   # first, identify the stepkid link
2892   my $cgi = $req->cgi;
2893   require BSE::TB::OtherParents;
2894   my $parentid = $cgi->param("parentid");
2895   defined $parentid
2896     or return $self->_service_error($req, $article, $articles, "Missing parentid", {}, "NOPARENTID");
2897   $parentid =~ /^\d+$/
2898     or return $self->_service_error($req, $article, $articles, "Invalid parentid", {}, "BADPARENTID");
2899
2900   my ($step) = BSE::TB::OtherParents->getBy(parentId => $parentid, childId => $article->id)
2901     or return $self->_service_error($req, $article, $articles, "Unknown relationship", {}, "NOTFOUND");
2902
2903   my $newparentid = $cgi->param("newparentid");
2904   if ($newparentid) {
2905     $newparentid =~ /^\d+$/
2906       or return $self->_service_error($req, $article, $articles, "Bad new parent id", {}, "BADNEWPARENT");
2907     my $new_parent = BSE::TB::Articles->getByPkey($newparentid)
2908       or return $self->_service_error($req, $article, $articles, "Unknown new parent id", {}, "UNKNOWNNEWPARENT");
2909     my $existing =
2910       BSE::TB::OtherParents->getBy(parentId=>$newparentid, childId=>$article->id)
2911         and return $self->_service_error($req, $article, $articles, "New parent is duplicate", {}, "NEWPARENTDUP");
2912
2913     $step->{parentId} = $newparentid;
2914     $step->save;
2915   }
2916
2917   my $after_id = $cgi->param("_after");
2918   if (defined $after_id) {
2919     BSE::TB::Articles->reorder_child($step->{parentId}, $article->id, $after_id);
2920   }
2921
2922   if ($req->is_ajax) {
2923     return $req->json_content
2924       (
2925        success => 1,
2926        relationshop => $step->data_only,
2927       );
2928   }
2929   else {
2930     return $self->refresh($article, $cgi, 'step', "Stepchild moved");
2931   }
2932 }
2933
2934 sub add_stepparent {
2935   my ($self, $req, $article, $articles) = @_;
2936
2937   $req->check_csrf("admin_add_stepparent")
2938     or return $self->csrf_error($req, $article, "admin_add_stepparent", "Add Stepparent");
2939
2940   $req->user_can(edit_stepparent_add => $article)
2941     or return $self->edit_form($req, $article, $articles,
2942                                "You don't have access to add stepparents to this article");
2943
2944   my $cgi = $req->cgi;
2945   require 'BSE/Admin/StepParents.pm';
2946   eval {
2947     my $step_parent_id = $cgi->param('stepparent');
2948     defined($step_parent_id)
2949       or die "No stepparent supplied to add_stepparent";
2950     int($step_parent_id) eq $step_parent_id
2951       or die "Invalid stepcat supplied to add_stepcat";
2952     my $step_parent = $articles->getByPkey($step_parent_id)
2953       or die "Parent $step_parent_id not found\n";
2954
2955     $req->user_can(edit_stepkid_add => $step_parent)
2956       or die "You don't have access to add a stepkid to that article\n";
2957
2958     my $release = $cgi->param('release');
2959     defined $release
2960       or $release = "01/01/2000";
2961     $release eq '' or dh_parse_date($release)
2962       or die "Invalid release date";
2963     my $expire = $cgi->param('expire');
2964     defined $expire
2965       or $expire = '31/12/2999';
2966     $expire eq '' or dh_parse_date($expire)
2967       or die "Invalid expire data";
2968
2969     my $newentry =
2970       BSE::Admin::StepParents->add($step_parent, $article, $release, $expire);
2971   };
2972   $@ and return $self->refresh($article, $cgi, 'step', $@);
2973
2974   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2975
2976   return $self->refresh($article, $cgi, 'stepparents', 'Stepparent added');
2977 }
2978
2979 sub del_stepparent {
2980   my ($self, $req, $article, $articles) = @_;
2981
2982   $req->check_csrf("admin_remove_stepparent")
2983     or return $self->csrf_error($req, $article, "admin_del_stepparent", "Delete Stepparent");
2984
2985   $req->user_can(edit_stepparent_delete => $article)
2986     or return $self->edit_form($req, $article, $articles,
2987                                "You cannot remove stepparents from that article");
2988
2989   my $cgi = $req->cgi;
2990   require 'BSE/Admin/StepParents.pm';
2991   my $step_parent_id = $cgi->param('stepparent');
2992   defined($step_parent_id)
2993     or return $self->refresh($article, $cgi, 'stepparents',
2994                              "No stepparent supplied to add_stepcat");
2995   int($step_parent_id) eq $step_parent_id
2996     or return $self->refresh($article, $cgi, 'stepparents',
2997                              "Invalid stepparent supplied to add_stepparent");
2998   my $step_parent = $articles->getByPkey($step_parent_id)
2999     or return $self->refresh($article, $cgi, 'stepparent',
3000                              "Stepparent $step_parent_id not found");
3001
3002   $req->user_can(edit_stepkid_delete => $step_parent)
3003     or die "You don't have access to remove the stepkid from that article\n";
3004
3005   eval {
3006     BSE::Admin::StepParents->del($step_parent, $article);
3007   };
3008   $@ and return $self->refresh($article, $cgi, 'stepparents', $@);
3009
3010   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3011
3012   return $self->refresh($article, $cgi, 'stepparents', 'Stepparent deleted');
3013 }
3014
3015 sub save_stepparents {
3016   my ($self, $req, $article, $articles) = @_;
3017
3018   $req->check_csrf("admin_save_stepparents")
3019     or return $self->csrf_error($req, $article, "admin_save_stepparents", "Save Stepparents");
3020   $req->user_can(edit_stepparent_save => $article)
3021     or return $self->edit_form($req, $article, $articles,
3022                                "No access to save stepparent data for this artice");
3023
3024   my $cgi = $req->cgi;
3025
3026   require 'BSE/Admin/StepParents.pm';
3027   my @stepparents = BSE::TB::OtherParents->getBy(childId=>$article->{id});
3028   my %stepparents = map { $_->{parentId}, $_ } @stepparents;
3029   my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
3030   for my $stepparent (@stepparents) {
3031     $req->user_can(edit_stepkid_save => $stepparent->{parentId})
3032       or next;
3033     for my $name (qw/release expire/) {
3034       my $date = $cgi->param($name.'_'.$stepparent->{parentId});
3035       if (defined $date) {
3036         if ($date eq '') {
3037           $date = $datedefs{$name};
3038         }
3039         elsif (dh_parse_date($date)) {
3040           use BSE::Util::SQL qw/date_to_sql/;
3041           $date = date_to_sql($date);
3042         }
3043         else {
3044           return $self->refresh($article, $cgi, "Invalid date '$date'");
3045         }
3046         $stepparent->{$name} = $date;
3047       }
3048     }
3049     eval {
3050       $stepparent->save();
3051     };
3052     $@ and return $self->refresh($article, $cgi, '', $@);
3053   }
3054
3055   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3056
3057   return $self->refresh($article, $cgi, 'stepparents',
3058                         'Stepparent information saved');
3059 }
3060
3061 sub refresh_url {
3062   my ($self, $article, $cgi, $name, $message, $extras) = @_;
3063
3064   my $url = $cgi->param('r');
3065   if ($url) {
3066     if ($url !~ /[?&](m|message)=/ && $message) {
3067       # add in messages if none in the provided refresh
3068       my @msgs = ref $message ? @$message : $message;
3069       my $sep = $url =~ /\?/ ? "&" : "?";
3070       for my $msg (@msgs) {
3071         $url .= $sep . "m=" . CGI::escape($msg);
3072       }
3073     }
3074   }
3075   else {
3076     my $urlbase = admin_base_url($self->{cfg});
3077     $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
3078     if ($message) {
3079       my @msgs = ref $message ? @$message : $message;
3080       for my $msg (@msgs) {
3081         $url .= "&m=" . CGI::escape($msg);
3082       }
3083     }
3084     if ($cgi->param('_t')) {
3085       $url .= "&_t=".CGI::escape($cgi->param('_t'));
3086     }
3087     $url .= $extras if defined $extras;
3088     my $cgiextras = $cgi->param('e');
3089     $url .= "#$name" if $name;
3090   }
3091
3092   return $url;
3093 }
3094
3095 sub refresh {
3096   my ($self, $article, $cgi, $name, $message, $extras) = @_;
3097
3098   my $url = $self->refresh_url($article, $cgi, $name, $message, $extras);
3099
3100   return BSE::Template->get_refresh($url, $self->{cfg});
3101 }
3102
3103 sub show_images {
3104   my ($self, $req, $article, $articles, $msg, $errors) = @_;
3105
3106   my %acts;
3107   %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
3108   my $template = 'admin/article_img';
3109
3110   return $req->dyn_response($template, \%acts);
3111 }
3112
3113 sub save_image_changes {
3114   my ($self, $req, $article, $articles) = @_;
3115
3116   $req->check_csrf("admin_save_images")
3117     or return $self->csrf_error($req, $article, "admin_save_images", "Save Images");
3118
3119   $req->user_can(edit_images_save => $article)
3120     or return $self->edit_form($req, $article, $articles,
3121                                  "You don't have access to save image information for this article");
3122
3123   my $image_dir = cfg_image_dir($req->cfg);
3124
3125   my $cgi = $req->cgi;
3126   my $image_pos = $cgi->param('imagePos');
3127   if ($image_pos
3128       && $image_pos =~ /^(?:tl|tr|bl|br|xx)$/
3129       && $image_pos ne $article->{imagePos}) {
3130     $article->{imagePos} = $image_pos;
3131     $article->save;
3132   }
3133   my @images = $self->get_images($article);
3134
3135   @images or
3136     return $self->refresh($article, $cgi, undef, 'No images to save information for');
3137
3138   my %changes;
3139   my %errors;
3140   my %names;
3141   my %old_images;
3142   my @new_images;
3143   for my $image (@images) {
3144     my $id = $image->{id};
3145
3146     my $alt = $cgi->param("alt$id");
3147     if ($alt ne $image->{alt}) {
3148       $changes{$id}{alt} = $alt;
3149     }
3150
3151     my $url = $cgi->param("url$id");
3152     if (defined $url && $url ne $image->{url}) {
3153       $changes{$id}{url} = $url;
3154     }
3155
3156     my $name = $cgi->param("name$id");
3157     if (defined $name && $name ne $image->{name}) {
3158       if ($name eq '') {
3159         $changes{$id}{name} = '';
3160       }
3161       elsif ($name =~ /^[a-z_]\w*$/i) {
3162         my $msg;
3163         if ($self->validate_image_name($name, \$msg)) {
3164           # check for duplicates after the loop
3165           push @{$names{lc $name}}, $image->{id}
3166             if length $name;
3167           $changes{$id}{name} = $name;
3168         }
3169         else {
3170           $errors{"name$id"} = $msg;
3171         }
3172       }
3173       else {
3174         $errors{"name$id"} = 'Image name must be empty or alphanumeric and unique to the article';
3175       }
3176     }
3177     else {
3178       push @{$names{lc $image->{name}}}, $image->{id}
3179         if length $image->{name};
3180     }
3181
3182     if ($cgi->param("_save_image_tags$image->{id}")) {
3183       my @tags = $cgi->param("tags$image->{id}");
3184       my @errors;
3185       my $index = 0;
3186       for my $tag (@tags) {
3187         my $error;
3188         if ($tag =~ /\S/
3189             && !BSE::TB::Tags->valid_name($tag, \$error)) {
3190           $errors[$index] = "msg:bse/admin/edit/tags/invalid/$error";
3191           $errors{"tags$image->{id}"} = \@errors;
3192         }
3193         ++$index;
3194       }
3195       unless (@errors) {
3196         $changes{$id}{tags} = [ grep /\S/, @tags ];
3197       }
3198     }
3199
3200     my $filename = $cgi->param("image$id");
3201     if (defined $filename && length $filename) {
3202       my $in_fh = $cgi->upload("image$id");
3203       if ($in_fh) {
3204         my $basename;
3205         my $image_error;
3206         my ($width, $height, $type) = $self->_validate_image
3207           ($filename, $in_fh, \$basename, \$image_error);
3208
3209         unless ($type) {
3210           $errors{"image$id"} = $image_error;
3211         }
3212
3213         unless ($errors{"image$id"}) {
3214           # work out where to put it
3215           require DevHelp::FileUpload;
3216           my $msg;
3217           my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3218             ($image_dir, $basename, \$msg);
3219           if ($image_name) {
3220             local $/ = \8192;
3221             my $data;
3222             while ($data = <$in_fh>) {
3223               print $out_fh $data;
3224             }
3225             close $out_fh;
3226
3227             my $full_filename = "$image_dir/$image_name";
3228             if ($width) {
3229               $old_images{$id} =
3230                 {
3231                  image => $image->{image},
3232                  storage => $image->{storage}
3233                 };
3234               push @new_images, $image_name;
3235
3236               $changes{$id}{image} = $image_name;
3237               $changes{$id}{storage} = 'local';
3238               $changes{$id}{src} = cfg_image_uri() . "/" . $image_name;
3239               $changes{$id}{width} = $width;
3240               $changes{$id}{height} = $height;
3241               $changes{$id}{ftype} = $self->_image_ftype($type);
3242             }
3243           }
3244           else {
3245             $errors{"image$id"} = $msg;
3246           }
3247         }
3248       }
3249       else {
3250         # problem uploading
3251         $errors{"image$id"} = "No image file received";
3252       }
3253     }
3254   }
3255   # look for duplicate names
3256   for my $name (keys %names) {
3257     if (@{$names{$name}} > 1) {
3258       for my $id (@{$names{$name}}) {
3259         $errors{"name$id"} = 'Image name must be unique to the article';
3260       }
3261     }
3262   }
3263   if (keys %errors) {
3264     # remove files that won't be stored because validation failed
3265     unlink map "$image_dir/$_", @new_images;
3266
3267     return $self->edit_form($req, $article, $articles, undef,
3268                             \%errors);
3269   }
3270
3271   my $mgr = $self->_image_manager($req->cfg);
3272   $req->flash('Image information saved');
3273   my $changes_found = 0;
3274   my $auto_store = $cgi->param('auto_storage');
3275   for my $image (@images) {
3276     my $id = $image->{id};
3277
3278     if ($changes{$id}) {
3279       my $changes = $changes{$id};
3280       ++$changes_found;
3281
3282       for my $field (keys %$changes) {
3283         my $tags = delete $changes->{$field};
3284         if ($tags) {
3285           my $error;
3286           $image->set_tags($tags, \$error);
3287         }
3288         $image->{$field} = $changes->{$field};
3289       }
3290       $image->save;
3291     }
3292
3293     my $old_storage = $image->{storage};
3294     my $new_storage = $auto_store ? '' : $cgi->param("storage$id");
3295     defined $new_storage or $new_storage = $image->{storage};
3296     $new_storage = $mgr->select_store($image->{image}, $new_storage, $image);
3297     if ($new_storage ne $old_storage) {
3298       eval {
3299         $image->{src} = $mgr->store($image->{image}, $new_storage, $image);
3300         $image->{storage} = $new_storage;
3301         $image->save;
3302       };
3303
3304       if ($old_storage ne 'local') {
3305         $mgr->unstore($image->{image}, $old_storage);
3306       }
3307     }
3308   }
3309
3310   # delete any image files that were replaced
3311   for my $old_image (values %old_images) {
3312     my ($image, $storage) = @$old_image{qw/image storage/};
3313     if ($storage ne 'local') {
3314       $mgr->unstore($image->{image}, $storage);
3315     }
3316     unlink "$image_dir/$image";
3317   }
3318
3319   if ($changes_found) {
3320     generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3321   }
3322
3323   return $self->refresh($article, $cgi);
3324 }
3325
3326 =item _service_error
3327
3328 This function is called on various errors.
3329
3330 If a _service parameter was supplied, returns text like:
3331
3332 =over
3333
3334 Result: failure
3335
3336 Field-Error: I<field-name1> - I<message1>
3337
3338 Field-Error: I<field-name2> - I<message2>
3339
3340 =back
3341
3342 If the request is detected as an ajax request or a _ parameter is
3343 supplied, return JSON like:
3344
3345   { error: I<message> }
3346
3347 Otherwise display the normal edit page with the error.
3348
3349 =cut
3350
3351 sub _service_error {
3352   my ($self, $req, $article, $articles, $msg, $error, $code, $method) = @_;
3353
3354   unless ($article) {
3355     my $mymsg;
3356     $article = $self->_dummy_article($req, $articles, \$mymsg);
3357     $article ||=
3358       {
3359        map $_ => '', BSE::TB::Article->columns
3360       };
3361   }
3362
3363   if ($req->cgi->param('_service')) {
3364     my $body = '';
3365     $body .= "Result: failure\n";
3366     if (ref $error) {
3367       for my $field (keys %$error) {
3368         my $text = $error->{$field};
3369         $text =~ tr/\n/ /;
3370         $body .= "Field-Error: $field - $text\n";
3371       }
3372       my $text = join ('/', values %$error);
3373       $text =~ tr/\n/ /;
3374       $body .= "Error: $text\n";
3375     }
3376     elsif ($msg) {
3377       $body .= "Error: $msg\n";
3378     }
3379     else {
3380       $body .= "Error: $error\n";
3381     }
3382     return
3383       {
3384        type => 'text/plain',
3385        content => $body,
3386       };
3387   }
3388   elsif ((() = $req->cgi->param('_')) ||
3389          (exists $ENV{HTTP_X_REQUESTED_WITH}
3390           && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/)) {
3391     $error ||= {};
3392     my $result =
3393       {
3394        errors => $error,
3395        success => 0,
3396       };
3397     $msg and $result->{message} = $msg;
3398     $code and $result->{error_code} = $code;
3399     my $json_result = $req->json_content($result);
3400
3401     if (!exists $ENV{HTTP_X_REQUESTED_WITH}
3402         || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
3403       $json_result->{type} = "text/plain";
3404     }
3405
3406     return $json_result;
3407   }
3408   else {
3409     $method ||= "edit_form";
3410     return $self->$method($req, $article, $articles, $msg, $error);
3411   }
3412 }
3413
3414 sub _service_success {
3415   my ($self, $results) = @_;
3416
3417   my $body = "Result: success\n";
3418   for my $field (keys %$results) {
3419     $body .= "$field: $results->{$field}\n";
3420   }
3421   return
3422     {
3423      type => 'text/plain',
3424      content => $body,
3425     };
3426 }
3427
3428 # FIXME: eliminate this method and call get_ftype directly
3429 sub _image_ftype {
3430   my ($self, $type) = @_;
3431
3432   require BSE::TB::Images;
3433   return BSE::TB::Images->get_ftype($type);
3434 }
3435
3436 my %valid_exts =
3437   (
3438    tiff => "tiff,tif",
3439    jpg => "jpeg,jpg",
3440    pnm => "pbm,pgm,ppm",
3441   );
3442
3443 sub _validate_image {
3444   my ($self, $filename, $fh, $rbasename, $error) = @_;
3445
3446   if ($fh) {
3447     if (-z $fh) {
3448       $$error = 'Image file is empty';
3449       return;
3450     }
3451   }
3452   else {
3453     $$error = 'Please enter an image filename';
3454     return;
3455   }
3456   my $imagename = $filename;
3457   $imagename .= ''; # force it into a string
3458   (my $basename = $imagename) =~ tr/A-Za-z0-9_./-/cs;
3459
3460   require BSE::ImageSize;
3461
3462   my ($width,$height, $type) = BSE::ImageSize::imgsize($fh);
3463
3464   unless (defined $width) {
3465     $$error = "Unknown image file type";
3466     return;
3467   }
3468
3469   my $lctype = lc $type;
3470   my @valid_exts = split /,/,
3471     BSE::Cfg->single->entry("valid image extensions", $lctype,
3472                 $valid_exts{$lctype} || $lctype);
3473
3474   my ($ext) = $basename =~ /\.(\w+)\z/;
3475   if (!$ext || !grep $_ eq lc $ext, @valid_exts) {
3476     $basename .= ".$valid_exts[0]";
3477   }
3478   $$rbasename = $basename;
3479
3480   return ($width, $height, $type);
3481 }
3482
3483 my $last_display_order = 0;
3484
3485 sub do_add_image {
3486   my ($self, $cfg, $article, $image, %opts) = @_;
3487
3488   my $errors = $opts{errors}
3489     or die "No errors parameter";
3490
3491   my $imageref = $opts{name};
3492   if (defined $imageref && $imageref ne '') {
3493     if ($imageref =~ /^[a-z_]\w+$/i) {
3494       # make sure it's unique
3495       my @images = $self->get_images($article);
3496       for my $img (@images) {
3497         if (defined $img->{name} && lc $img->{name} eq lc $imageref) {
3498           $errors->{name} = 'Image name must be unique to the article';
3499           last;
3500         }
3501       }
3502     }
3503     else {
3504       $errors->{name} = 'Image name must be empty or alphanumeric beginning with an alpha character';
3505     }
3506   }
3507   else {
3508     $imageref = '';
3509   }
3510   unless ($errors->{name}) {
3511     my $workmsg;
3512     $self->validate_image_name($imageref, \$workmsg)
3513       or $errors->{name} = $workmsg;
3514   }
3515
3516   my $image_error;
3517   my $basename;
3518   my ($width, $height, $type) =
3519     $self->_validate_image($opts{filename} || $image, $image, \$basename,
3520                            \$image_error);
3521   unless ($width) {
3522     $errors->{image} = $image_error;
3523   }
3524
3525   keys %$errors
3526     and return;
3527
3528   # for the sysopen() constants
3529   use Fcntl;
3530
3531   my $imagedir = cfg_image_dir($cfg);
3532
3533   require DevHelp::FileUpload;
3534   my $msg;
3535   my ($filename, $fh) =
3536     DevHelp::FileUpload->make_img_filename($imagedir, $basename, \$msg);
3537   unless ($filename) {
3538     $errors->{image} = $msg;
3539     return;
3540   }
3541
3542   my $buffer;
3543
3544   binmode $fh;
3545
3546   no strict 'refs';
3547
3548   # read the image in from the browser and output it to our output filehandle
3549   print $fh $buffer while read $image, $buffer, 1024;
3550
3551   # close and flush
3552   close $fh
3553     or die "Could not close image file $filename: $!";
3554
3555   my $display_order = time;
3556   if ($display_order <= $last_display_order) {
3557     $display_order = $last_display_order + 1;
3558   }
3559   $last_display_order = $display_order;
3560
3561   my $alt = $opts{alt};
3562   defined $alt or $alt = '';
3563   my $url = $opts{url};
3564   defined $url or $url = '';
3565   my %image =
3566     (
3567      articleId => $article->{id},
3568      image => $filename,
3569      alt=>$alt,
3570      width=>$width,
3571      height => $height,
3572      url => $url,
3573      displayOrder => $display_order,
3574      name => $imageref,
3575      storage => 'local',
3576      src => cfg_image_uri() . '/' . $filename,
3577      ftype => $self->_image_ftype($type),
3578     );
3579   require BSE::TB::Images;
3580   my @cols = BSE::TB::Image->columns;
3581   shift @cols;
3582   my $imageobj = BSE::TB::Images->add(@image{@cols});
3583
3584   my $storage = $opts{storage};
3585   defined $storage or $storage = 'local';
3586   my $image_manager = $self->_image_manager($cfg);
3587   local $SIG{__DIE__};
3588   eval {
3589     my $src;
3590     $storage = $image_manager->select_store($filename, $storage, $imageobj);
3591     $src = $image_manager->store($filename, $storage, $imageobj);
3592
3593     if ($src) {
3594       $imageobj->{src} = $src;
3595       $imageobj->{storage} = $storage;
3596       $imageobj->save;
3597     }
3598   };
3599   if ($@) {
3600     $errors->{flash} = $@;
3601   }
3602
3603   return $imageobj;
3604 }
3605
3606 sub _image_data {
3607   my ($self, $cfg, $image) = @_;
3608
3609   my $data = $image->data_only;
3610   $data->{src} = $image->image_url($cfg);
3611
3612   return $data;
3613 }
3614
3615 sub add_image {
3616   my ($self, $req, $article, $articles) = @_;
3617
3618   $req->check_csrf("admin_add_image")
3619     or return $self->csrf_error($req, $article, "admin_add_image", "Add Image");
3620   $req->user_can(edit_images_add => $article)
3621     or return $self->_service_error($req, $article, $articles,
3622                                     "You don't have access to add new images to this article");
3623
3624   my $cgi = $req->cgi;
3625
3626   my %errors;
3627
3628   my $save_tags = $cgi->param("_save_tags");
3629   my @tags;
3630   if ($save_tags) {
3631     @tags = $cgi->param("tags");
3632     $self->_validate_tags(\@tags, \%errors);
3633   }
3634
3635   my $imageobj =
3636     $self->do_add_image
3637       (
3638        $req->cfg,
3639        $article,
3640        scalar($cgi->upload('image')),
3641        name => scalar($cgi->param('name')),
3642        alt => scalar($cgi->param('altIn')),
3643        url => scalar($cgi->param('url')),
3644        storage => scalar($cgi->param('storage')),
3645        errors => \%errors,
3646        filename => scalar($cgi->param("image")),
3647       );
3648
3649   $imageobj
3650     or return $self->_service_error($req, $article, $articles, undef, \%errors);
3651
3652   if ($save_tags) {
3653     my $error;
3654     $imageobj->set_tags([ grep /\S/, @tags ], \$error);
3655   }
3656
3657   # typically a soft failure from the storage
3658   $errors{flash}
3659     and $req->flash($errors{flash});
3660
3661   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3662
3663   if ($cgi->param('_service')) {
3664     return $self->_service_success
3665       (
3666        {
3667         image => $imageobj->{id},
3668        },
3669       );
3670   }
3671   elsif ($cgi->param("_") || $req->is_ajax) {
3672     my $resp = $req->json_content
3673       (
3674        success => 1,
3675        image => $self->_image_data($req->cfg, $imageobj),
3676       );
3677
3678     # the browser handles this directly, tell it that it's text
3679     $resp->{type} = "text/plain";
3680
3681     return $resp;
3682   }
3683   else {
3684     return $self->refresh($article, $cgi, undef, 'New image added');
3685   }
3686 }
3687
3688 sub _image_manager {
3689   my ($self) = @_;
3690
3691   require BSE::TB::Images;
3692   return BSE::TB::Images->storage_manager;
3693 }
3694
3695 # remove an image
3696 sub remove_img {
3697   my ($self, $req, $article, $articles, $imageid) = @_;
3698
3699   $req->check_csrf("admin_remove_image")
3700     or return $self->csrf_error($req, $article, "admin_remove_image", "Remove Image");
3701
3702   $req->user_can(edit_images_delete => $article)
3703     or return $self->_service_error($req, $article, $articles,
3704                                  "You don't have access to delete images from this article", {}, "ACCESS");
3705
3706   $imageid or die;
3707
3708   my @images = $self->get_images($article);
3709   my ($image) = grep $_->{id} == $imageid, @images;
3710   unless ($image) {
3711     if ($req->want_json_response) {
3712       return $self->_service_error($req, $article, $articles, "No such image", {}, "NOTFOUND");
3713     }
3714     else {
3715       return $self->show_images($req, $article, $articles, "No such image");
3716     }
3717   }
3718
3719   if ($image->{storage} ne 'local') {
3720     my $mgr = $self->_image_manager($req->cfg);
3721     $mgr->unstore($image->{image}, $image->{storage});
3722   }
3723
3724   my $imagedir = cfg_image_dir($req->cfg);
3725   $image->remove;
3726
3727   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3728
3729   if ($req->want_json_response) {
3730     return $req->json_content
3731       (
3732        success => 1,
3733       );
3734   }
3735
3736   return $self->refresh($article, $req->cgi, undef, 'Image removed');
3737 }
3738
3739 sub move_img_up {
3740   my ($self, $req, $article, $articles) = @_;
3741
3742   $req->check_csrf("admin_move_image")
3743     or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
3744   $req->user_can(edit_images_reorder => $article)
3745     or return $self->edit_form($req, $article, $articles,
3746                                  "You don't have access to reorder images in this article");
3747
3748   my $imageid = $req->cgi->param('imageid');
3749   my @images = $self->get_images($article);
3750   my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
3751     or return $self->edit_form($req, $article, $articles, "No such image");
3752   $imgindex > 0
3753     or return $self->edit_form($req, $article, $articles, "Image is already at the top");
3754   my ($to, $from) = @images[$imgindex-1, $imgindex];
3755   ($to->{displayOrder}, $from->{displayOrder}) =
3756     ($from->{displayOrder}, $to->{displayOrder});
3757   $to->save;
3758   $from->save;
3759
3760   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3761
3762   return $self->refresh($article, $req->cgi, undef, 'Image moved');
3763 }
3764
3765 sub move_img_down {
3766   my ($self, $req, $article, $articles) = @_;
3767
3768   $req->check_csrf("admin_move_image")
3769     or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
3770   $req->user_can(edit_images_reorder => $article)
3771     or return $self->edit_form($req, $article, $articles,
3772                                  "You don't have access to reorder images in this article");
3773
3774   my $imageid = $req->cgi->param('imageid');
3775   my @images = $self->get_images($article);
3776   my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
3777     or return $self->edit_form($req, $article, $articles, "No such image");
3778   $imgindex < $#images
3779     or return $self->edit_form($req, $article, $articles, "Image is already at the end");
3780   my ($to, $from) = @images[$imgindex+1, $imgindex];
3781   ($to->{displayOrder}, $from->{displayOrder}) =
3782     ($from->{displayOrder}, $to->{displayOrder});
3783   $to->save;
3784   $from->save;
3785
3786   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3787
3788   return $self->refresh($article, $req->cgi, undef, 'Image moved');
3789 }
3790
3791 sub req_thumb {
3792   my ($self, $req, $article) = @_;
3793
3794   my $cgi = $req->cgi;
3795   my $cfg = $req->cfg;
3796   my $im_id = $cgi->param('im');
3797   my $image;
3798   if (defined $im_id && $im_id =~ /^\d+$/) {
3799     ($image) = grep $_->{id} == $im_id, $self->get_images($article);
3800   }
3801   my $thumb_obj = $self->_get_thumbs_class();
3802   my ($data, $type);
3803   if ($image && $thumb_obj) {
3804     my $geometry_id = $cgi->param('g');
3805     defined $geometry_id or $geometry_id = 'editor';
3806     my $geometry = $cfg->entry('thumb geometries', $geometry_id, 'scale(200x200)');
3807     my $imagedir = cfg_image_dir();
3808
3809     my $error;
3810     ($data, $type) = $thumb_obj->thumb_data
3811       (
3812        filename => "$imagedir/$image->{image}",
3813        geometry => $geometry,
3814        error => \$error
3815       )
3816         or return
3817           {
3818            type => 'text/plain',
3819            content => 'Error: '.$error
3820           };
3821   }
3822
3823   if ($type && $data) {
3824
3825     return
3826       {
3827        type => $type,
3828        content => $data,
3829        headers => [
3830                    "Content-Length: ".length($data),
3831                    "Cache-Control: max-age=3600",
3832                   ],
3833       };
3834   }
3835   else {
3836     # grab the nothumb image
3837     my $uri = $cfg->entry('editor', 'default_thumbnail', cfg_dist_image_uri() . '/admin/nothumb.png');
3838     my $filebase = $cfg->content_base_path;
3839     if (open IMG, "<$filebase/$uri") {
3840       binmode IMG;
3841       my $data = do { local $/; <IMG> };
3842       close IMG;
3843       my $type = $uri =~ /\.(\w+)$/ ? $1 : 'png';
3844       return
3845         {
3846          type => "image/$type",
3847          content => $data,
3848          headers => [ "Content-Length: ".length($data) ],
3849         };
3850     }
3851     else {
3852       return
3853         {
3854          type=>"text/html",
3855          content => "<html><body>Cannot make thumb or default image</body></html>",
3856         };
3857     }
3858   }
3859 }
3860
3861 =item edit_image
3862
3863 Display a form to allow editing an image.
3864
3865 Tags:
3866
3867 =over
3868
3869 =item *
3870
3871 eimage - the image being edited
3872
3873 =item *
3874
3875 normal article edit tags.
3876
3877 =back
3878
3879 Variables:
3880
3881 eimage - the image being edited.
3882
3883 =cut
3884
3885 sub req_edit_image {
3886   my ($self, $req, $article, $articles, $errors) = @_;
3887
3888   my $cgi = $req->cgi;
3889
3890   my $id = $cgi->param('image_id');
3891
3892   my ($image) = grep $_->{id} == $id, $self->get_images($article)
3893     or return $self->edit_form($req, $article, $articles,
3894                                "No such image");
3895   $req->user_can(edit_images_save => $article)
3896     or return $self->edit_form($req, $article, $articles,
3897                                "You don't have access to save image information for this article");
3898
3899   $req->set_variable(eimage => $image);
3900
3901   my %acts;
3902   %acts =
3903     (
3904      $self->low_edit_tags(\%acts, $req, $article, $articles, undef,
3905                           $errors),
3906      eimage => [ \&tag_hash, $image ],
3907      error_img => [ \&tag_error_img, $req->cfg, $errors ],
3908     );
3909
3910   return $req->response('admin/image_edit', \%acts);
3911 }
3912
3913 =item a_save_image
3914
3915 Save changes to an image.
3916
3917 Parameters:
3918
3919 =over
3920
3921 =item *
3922
3923 id - article id
3924
3925 =item *
3926
3927 image_id - image id
3928
3929 =item *
3930
3931 alt, url, name - text fields to update
3932
3933 =item *
3934
3935 image - replacement image data (if any)
3936
3937 =back
3938
3939 =cut
3940
3941 sub req_save_image {
3942   my ($self, $req, $article, $articles) = @_;
3943
3944   $req->check_csrf("admin_save_image")
3945     or return $self->csrf_error($req, $article, "admin_save_image", "Save Image");
3946   my $cgi = $req->cgi;
3947
3948   my $id = $cgi->param('image_id');
3949
3950   my @images = $self->get_images($article);
3951   my ($image) = grep $_->{id} == $id, @images
3952     or return $self->_service_error($req, $article, $articles, "No such image",
3953                                     {}, "NOTFOUND");
3954   $req->user_can(edit_images_save => $article)
3955     or return $self->_service_error($req, $article, $articles,
3956                                     "You don't have access to save image information for this article", {}, "ACCESS");
3957
3958   my $image_dir = cfg_image_dir($req->cfg);
3959
3960   my $old_storage = $image->{storage};
3961
3962   my %errors;
3963   my $delete_file;
3964   my $alt = $cgi->param('alt');
3965   defined $alt and $image->{alt} = $alt;
3966   my $url = $cgi->param('url');
3967   defined $url and $image->{url} = $url;
3968   my @other_images = grep $_->{id} != $id, @images;
3969   my $name = $cgi->param('name');
3970   if (defined $name) {
3971     if (length $name) {
3972       if ($name !~ /^[a-z_]\w*$/i) {
3973         $errors{name} = 'Image name must be empty or alphanumeric and unique to the article';
3974       }
3975       elsif (grep $name eq $_->{name}, @other_images) {
3976         $errors{name} = 'Image name must be unique to the article';
3977       }
3978       else {
3979         $image->{name} = $name;
3980       }
3981     }
3982     else {
3983       $image->{name} = '';
3984     }
3985   }
3986   my $filename = $cgi->param('image');
3987   if (defined $filename && length $filename) {
3988     my $in_fh = $cgi->upload('image');
3989     if ($in_fh) {
3990       my $basename;
3991       my $image_error;
3992       my ($width, $height, $type) = $self->_validate_image
3993         ($filename, $in_fh, \$basename, \$image_error);
3994       if ($type) {
3995         require DevHelp::FileUpload;
3996         my $msg;
3997         my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3998           ($image_dir, $basename, \$msg);
3999         if ($image_name) {
4000           {
4001             local $/ = \8192;
4002             my $data;
4003             while ($data = <$in_fh>) {
4004               print $out_fh $data;
4005             }
4006             close $out_fh;
4007           }
4008
4009           my $full_filename = "$image_dir/$image_name";
4010           $delete_file = $image->{image};
4011           $image->{image} = $image_name;
4012           $image->{width} = $width;
4013           $image->{height} = $height;
4014           $image->{storage} = 'local'; # not on the remote store yet
4015           $image->{src} = cfg_image_uri() . '/' . $image_name;
4016           $image->{ftype} = $self->_image_ftype($type);
4017         }
4018         else {
4019           $errors{image} = $msg;
4020         }
4021       }
4022       else {
4023         $errors{image} = $image_error;
4024       }
4025     }
4026     else {
4027       $errors{image} = "No image file received";
4028     }
4029   }
4030   my $save_tags = $cgi->param("_save_tags");
4031   my @tags;
4032   if ($save_tags) {
4033     @tags = $cgi->param("tags");
4034     $self->_validate_tags(\@tags, \%errors);
4035   }
4036   if (keys %errors) {
4037     if ($req->want_json_response) {
4038       return $self->_service_error($req, $article, $articles, undef,
4039                                    \%errors, "FIELD");
4040     }
4041     else {
4042       return $self->req_edit_image($req, $article, $articles, \%errors);
4043     }
4044   }
4045
4046   my $new_storage = $cgi->param('storage');
4047   defined $new_storage or $new_storage = $image->{storage};
4048   $image->save;
4049   if ($save_tags) {
4050     my $error;
4051     $image->set_tags([ grep /\S/, @tags ], \$error);
4052   }
4053   my $mgr = $self->_image_manager($req->cfg);
4054   if ($delete_file) {
4055     if ($old_storage ne 'local') {
4056       $mgr->unstore($delete_file, $old_storage);
4057     }
4058     unlink "$image_dir/$delete_file";
4059   }
4060   $req->flash("Image saved");
4061   eval {
4062     $new_storage =
4063       $mgr->select_store($image->{image}, $new_storage);
4064     if ($image->{storage} ne $new_storage) {
4065       # handles both new images (which sets storage to local) and changing
4066       # the storage for old images
4067       my $old_storage = $image->{storage};
4068       my $src = $mgr->store($image->{image}, $new_storage, $image);
4069       $image->{src} = $src;
4070       $image->{storage} = $new_storage;
4071       $image->save;
4072     }
4073   };
4074   $@ and $req->flash("There was a problem adding it to the new storage: $@");
4075   if ($image->{storage} ne $old_storage && $old_storage ne 'local') {
4076     eval {
4077       $mgr->unstore($image->{image}, $old_storage);
4078     };
4079     $@ and $req->flash("There was a problem removing if from the old storage: $@");
4080   }
4081
4082   if ($req->want_json_response) {
4083     return $req->json_content
4084       (
4085        success => 1,
4086        image => $self->_image_data($req->cfg, $image),
4087       );
4088   }
4089
4090   return $self->refresh($article, $cgi);
4091 }
4092
4093 =item a_order_images
4094
4095 Change the order of images for an article (or global images).
4096
4097 Ajax only.
4098
4099 =over
4100
4101 =item *
4102
4103 id - id of the article to change the image order for (-1 for global
4104 images)
4105
4106 =item *
4107
4108 order - comma-separated list of image ids in the new order.
4109
4110 =back
4111
4112 =cut
4113
4114 sub req_order_images {
4115   my ($self, $req, $article, $articles) = @_;
4116
4117   $req->is_ajax
4118     or return $self->_service_error($req, $article, $articles, "The function only permitted from Ajax", {}, "AJAXONLY");
4119
4120   my $order = $req->cgi->param("order");
4121   defined $order
4122     or return $self->_service_error($req, $article, $articles, "order not supplied", {}, "NOORDER");
4123   $order =~ /^\d+(,\d+)*$/
4124     or return $self->_service_error($req, $article, $articles, "order not supplied", {}, "BADORDER");
4125
4126   my @order = split /,/, $order;
4127
4128   my @images = $article->set_image_order(\@order);
4129
4130   return $req->json_content
4131     (
4132      success => 1,
4133      images =>
4134      [
4135       map $self->_image_data($req->cfg, $_), @images
4136      ],
4137     );
4138 }
4139
4140 sub get_article {
4141   my ($self, $articles, $article) = @_;
4142
4143   return $article;
4144 }
4145
4146 sub table_object {
4147   my ($self, $articles) = @_;
4148
4149   $articles;
4150 }
4151
4152 sub _refresh_filelist {
4153   my ($self, $req, $article, $msg) = @_;
4154
4155   return $self->refresh($article, $req->cgi, undef, $msg);
4156 }
4157
4158 sub filelist {
4159   my ($self, $req, $article, $articles, $msg, $errors) = @_;
4160
4161   my %acts;
4162   %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
4163   my $template = 'admin/filelist';
4164
4165   return BSE::Template->get_response($template, $req->cfg, \%acts);
4166 }
4167
4168 my %file_fields =
4169   (
4170    file =>
4171    {
4172     maxlength => MAX_FILE_DISPLAYNAME_LENGTH,
4173     description => 'Filename'
4174    },
4175    description =>
4176    {
4177     rules => 'dh_one_line',
4178     maxlength => 255,
4179     description => 'Description',
4180    },
4181    name =>
4182    {
4183     description => 'Identifier',
4184     maxlength => 80,
4185    },
4186    category =>
4187    {
4188     description => "Category",
4189     maxlength => 20,
4190    },
4191   );
4192
4193 sub fileadd {
4194   my ($self, $req, $article, $articles) = @_;
4195
4196   $req->check_csrf("admin_add_file")
4197     or return $self->csrf_error($req, $article, "admin_add_file", "Add File");
4198   $req->user_can(edit_files_add => $article)
4199     or return $self->_service_error($req, $article, $articles,
4200                               "You don't have access to add files to this article");
4201
4202   my %file;
4203   my $cgi = $req->cgi;
4204   require BSE::TB::ArticleFiles;
4205   my @cols = BSE::TB::ArticleFile->columns;
4206   shift @cols;
4207   for my $col (@cols) {
4208     if (defined $cgi->param($col)) {
4209       $file{$col} = $cgi->param($col);
4210     }
4211   }
4212
4213   my %errors;
4214
4215   $req->validate(errors => \%errors,
4216                  fields => \%file_fields,
4217                  section => $article->{id} == -1 ? 'Global File Validation' : 'Article File Validation');
4218
4219   # build a filename
4220   my $file = $cgi->upload('file');
4221   my $filename = $cgi->param("file");
4222   unless ($file) {
4223     $errors{file} = 'Please enter a filename';
4224   }
4225   if ($file && -z $file) {
4226     $errors{file} = 'File is empty';
4227   }
4228
4229   $file{forSale}        = 0 + exists $file{forSale};
4230   $file{articleId}      = $article->{id};
4231   $file{download}       = 0 + exists $file{download};
4232   $file{requireUser}    = 0 + exists $file{requireUser};
4233   $file{hide_from_list} = 0 + exists $file{hide_from_list};
4234   $file{category}       ||= '';
4235
4236   defined $file{name} or $file{name} = '';
4237   if (!$errors{name} && length $file{name} && $file{name} !~/^\w+$/) {
4238     $errors{name} = "Identifier must be a single word";
4239   }
4240   if (!$errors{name} && length $file{name}) {
4241     my @files = $self->get_files($article);
4242     if (grep lc $_->{name} eq lc $file{name}, @files) {
4243       $errors{name} = "Duplicate file identifier $file{name}";
4244     }
4245   }
4246
4247   keys %errors
4248     and return $self->_service_error($req, $article, $articles, undef, \%errors);
4249
4250   my $basename = '';
4251   my $workfile = $filename;
4252   $workfile =~ s![^\w.:/\\-]+!_!g;
4253   $workfile =~ tr/_/_/s;
4254   $workfile =~ /([ \w.-]+)$/ and $basename = $1;
4255   $basename =~ tr/ /_/;
4256   $file{displayName} = $basename;
4257   $file{file} = $file;
4258
4259   local $SIG{__DIE__};
4260   my $fileobj =
4261     eval {
4262       $article->add_file($self->cfg, %file);
4263     };
4264
4265   $fileobj
4266     or return $self->_service_error($req, $article, $articles, $@);
4267
4268   unless ($req->is_ajax) {
4269     $req->flash("New file added");
4270   }
4271
4272   my $json =
4273     {
4274      success => 1,
4275      file => $fileobj->data_only,
4276      warnings => [],
4277     };
4278   my $storage = $cgi->param("storage") || "";
4279   eval {
4280     my $msg;
4281
4282     $article->apply_storage($self->cfg, $fileobj, $storage, \$msg);
4283
4284     if ($msg) {
4285       if ($req->is_ajax) {
4286         push @{$json->{warnings}}, $msg;
4287       }
4288       else {
4289         $req->flash_error($msg);
4290       }
4291     }
4292   };
4293   if ($@) {
4294     if ($req->is_ajax) {
4295       push @{$json->{warnings}}, $@;
4296     }
4297     else {
4298       $req->flash_error($@);
4299     }
4300   }
4301
4302   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4303
4304   if ($req->is_ajax) {
4305     return $req->json_content($json);
4306   }
4307   else {
4308     $self->_refresh_filelist($req, $article);
4309   }
4310 }
4311
4312 sub fileswap {
4313   my ($self, $req, $article, $articles) = @_;
4314
4315   $req->check_csrf("admin_move_file")
4316     or return $self->csrf_error($req, $article, "admin_move_file", "Move File");
4317
4318   $req->user_can('edit_files_reorder', $article)
4319     or return $self->edit_form($req, $article, $articles,
4320                            "You don't have access to reorder files in this article");
4321
4322   my $cgi = $req->cgi;
4323   my $id1 = $cgi->param('file1');
4324   my $id2 = $cgi->param('file2');
4325
4326   if ($id1 && $id2) {
4327     my @files = $self->get_files($article);
4328
4329     my ($file1) = grep $_->{id} == $id1, @files;
4330     my ($file2) = grep $_->{id} == $id2, @files;
4331
4332     if ($file1 && $file2) {
4333       ($file1->{displayOrder}, $file2->{displayOrder})
4334         = ($file2->{displayOrder}, $file1->{displayOrder});
4335       $file1->save;
4336       $file2->save;
4337     }
4338   }
4339
4340   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4341
4342   $self->refresh($article, $req->cgi, undef, 'File moved');
4343 }
4344
4345 sub filedel {
4346   my ($self, $req, $article, $articles) = @_;
4347
4348   $req->check_csrf("admin_remove_file")
4349     or return $self->csrf_error($req, $article, "admin_remove_file", "Delete File");
4350   $req->user_can('edit_files_delete', $article)
4351     or return $self->edit_form($req, $article, $articles,
4352                                "You don't have access to delete files from this article");
4353
4354   my $cgi = $req->cgi;
4355   my $fileid = $cgi->param('file');
4356   if ($fileid) {
4357     my @files = $self->get_files($article);
4358
4359     my ($file) = grep $_->{id} == $fileid, @files;
4360
4361     if ($file) {
4362       if ($file->{storage} ne 'local') {
4363         my $mgr = $self->_file_manager($self->cfg);
4364         $mgr->unstore($file->{filename}, $file->{storage});
4365       }
4366
4367       $file->remove($req->cfg);
4368     }
4369   }
4370
4371   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4372
4373   $self->_refresh_filelist($req, $article, 'File deleted');
4374 }
4375
4376 sub filesave {
4377   my ($self, $req, $article, $articles) = @_;
4378
4379   $req->check_csrf("admin_save_files")
4380     or return $self->csrf_error($req, $article, "admin_save_files", "Save Files");
4381
4382   $req->user_can('edit_files_save', $article)
4383     or return $self->edit_form($req, $article, $articles,
4384                            "You don't have access to save file information for this article");
4385   my @files = $self->get_files($article);
4386
4387   my $download_path = BSE::TB::ArticleFiles->download_path($self->{cfg});
4388
4389   my $cgi = $req->cgi;
4390   my %names;
4391   my %errors;
4392   my @old_files;
4393   my @new_files;
4394   my %store_anyway;
4395   my $change_count = 0;
4396   my @content_changed;
4397   for my $file (@files) {
4398     my $id = $file->{id};
4399     my $orig = $file->data_only;
4400     my $desc = $cgi->param("description_$id");
4401     defined $desc and $file->{description} = $desc;
4402     my $type = $cgi->param("contentType_$id");
4403     if (defined $type and $type ne $file->{contentType}) {
4404       ++$store_anyway{$id};
4405       $file->{contentType} = $type;
4406     }
4407     my $notes = $cgi->param("notes_$id");
4408     defined $notes and $file->{notes} = $notes;
4409     my $category = $cgi->param("category_$id");
4410     defined $category and $file->{category} = $category;
4411     my $name = $cgi->param("name_$id");
4412     if (defined $name) {
4413       $file->{name} = $name;
4414       if (length $name) {
4415         if ($name =~ /^\w+$/) {
4416           push @{$names{$name}}, $id;
4417         }
4418         else {
4419           $errors{"name_$id"} = "Invalid file identifier $name";
4420         }
4421       }
4422     }
4423     else {
4424       push @{$names{$file->{name}}}, $id
4425         if length $file->{name};
4426     }
4427     if ($cgi->param('save_file_flags')) {
4428       my $download = 0 + defined $cgi->param("download_$id");
4429       if ($download != $file->{download}) {
4430         ++$store_anyway{$file->{id}};
4431         $file->{download}             = $download;
4432       }
4433       $file->{forSale}        = 0 + defined $cgi->param("forSale_$id");
4434       $file->{requireUser}    = 0 + defined $cgi->param("requireUser_$id");
4435       $file->{hide_from_list} = 0 + defined $cgi->param("hide_from_list_$id");
4436     }
4437
4438     my $filex = $cgi->param("file_$id");
4439     my $in_fh = $cgi->upload("file_$id");
4440     if (defined $filex && length $filex) {
4441       if (length $filex <= MAX_FILE_DISPLAYNAME_LENGTH) {
4442         if ($in_fh) {
4443           if (-s $in_fh) {
4444             require DevHelp::FileUpload;
4445             my $msg;
4446             my ($file_name, $out_fh) = DevHelp::FileUpload->make_img_filename
4447               ($download_path, $filex . '', \$msg);
4448             if ($file_name) {
4449               {
4450                 local $/ = \8192;
4451                 my $data;
4452                 while ($data = <$in_fh>) {
4453                   print $out_fh $data;
4454                 }
4455                 close $out_fh;
4456               }
4457               my $display_name = $filex;
4458               $display_name =~ s!.*[\\:/]!!;
4459               $display_name =~ s/[^\w._-]+/_/g;
4460               my $full_name = "$download_path/$file_name";
4461               push @old_files, [ $file->{filename}, $file->{storage} ];
4462               push @new_files, $file_name;
4463
4464               $file->{filename} = $file_name;
4465               $file->{storage} = 'local';
4466               $file->{sizeInBytes} = -s $full_name;
4467               $file->{whenUploaded} = now_sqldatetime();
4468               $file->{displayName} = $display_name;
4469               push @content_changed, $file;
4470             }
4471             else {
4472               $errors{"file_$id"} = $msg;
4473             }
4474           }
4475           else {
4476             $errors{"file_$id"} = "File is empty";
4477           }
4478         }
4479         else {
4480           $errors{"file_$id"} = "No file data received";
4481         }
4482       }
4483       else {
4484         $errors{"file_$id"} = "Filename too long";
4485       }
4486     }
4487
4488     my $new = $file->data_only;
4489   COLUMN:
4490     for my $col ($file->columns) {
4491       if ($new->{$col} ne $orig->{$col}) {
4492         ++$change_count;
4493         last COLUMN;
4494       }
4495     }
4496   }
4497   for my $name (keys %names) {
4498     if (@{$names{$name}} > 1) {
4499       for my $id (@{$names{$name}}) {
4500         $errors{"name_$id"} = 'File identifier must be unique to the article';
4501       }
4502     }
4503   }
4504   if (keys %errors) {
4505     # remove the uploaded replacements
4506     unlink map "$download_path/$_", @new_files;
4507
4508     return $self->edit_form($req, $article, $articles, undef, \%errors);
4509   }
4510   if ($change_count) {
4511     $req->flash("msg:bse/admin/edit/file/save/success_count", [ $change_count ]);
4512   }
4513   else {
4514     $req->flash("msg:bse/admin/edit/file/save/success_none");
4515   }
4516   my $mgr = $self->_file_manager($self->cfg);
4517   for my $file (@files) {
4518     $file->save;
4519
4520     my $storage = $cgi->param("storage_$file->{id}");
4521     defined $storage or $storage = 'local';
4522     my $msg;
4523     $storage = $article->select_filestore($mgr, $file, $storage, \$msg);
4524     $msg and $req->flash($msg);
4525     if ($storage ne $file->{storage} || $store_anyway{$file->{id}}) {
4526       my $old_storage = $file->{storage};
4527       eval {
4528         $file->{src} = $mgr->store($file->{filename}, $storage, $file);
4529         $file->{storage} = $storage;
4530         $file->save;
4531
4532         if ($old_storage ne $storage) {
4533           $mgr->unstore($file->{filename}, $old_storage);
4534         }
4535       };
4536       $@
4537         and $req->flash("Could not move $file->{displayName} to $storage: $@");
4538     }
4539   }
4540
4541   # remove the replaced files
4542   for my $file (@old_files) {
4543     my ($filename, $storage) = @$file;
4544
4545     eval {
4546       $mgr->unstore($filename, $storage);
4547     };
4548     $@
4549       and $req->flash("Error removing $filename from $storage: $@");
4550
4551     unlink "$download_path/$filename";
4552   }
4553
4554   # update file type metadatas
4555   for my $file (@content_changed) {
4556     $file->set_handler($self->{cfg});
4557     $file->save;
4558   }
4559
4560   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4561
4562   $self->_refresh_filelist($req, $article);
4563 }
4564
4565 sub req_filemeta {
4566   my ($self, $req, $article, $articles, $errors) = @_;
4567
4568   my $cgi = $req->cgi;
4569
4570   my $id = $cgi->param('file_id');
4571
4572   my ($file) = grep $_->{id} == $id, $self->get_files($article)
4573     or return $self->edit_form($req, $article, $articles,
4574                                "No such file");
4575   $req->user_can(edit_files_save => $article)
4576     or return $self->edit_form($req, $article, $articles,
4577                                "You don't have access to save file information for this article");
4578
4579   my $name = $cgi->param('name');
4580   $name && $name =~ /^\w+$/
4581     or return $self->edit_form($req, $article, $articles,
4582                    &n