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