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.055";
  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   my $article_type = $cfg->entry('level names', $article->{level}, 'Article');
1297   $request->set_variable(article_type => $article_type);
1298
1299   return
1300     (
1301      $request->admin_tags,
1302      article => sub { tag_article($article, $cfg, $_[0]) },
1303      old => [ \&tag_old, $article, $cgi ],
1304      default => [ \&tag_default, $self, $request, $article ],
1305      articleType => escape_html($article_type),
1306      parentType => [ \&tag_art_type, $article->{level}-1, $cfg ],
1307      ifNew => [ \&tag_if_new, $article ],
1308      list => [ \&tag_list, $self, $article, $articles, $cgi, $request ],
1309      script => $ENV{SCRIPT_NAME},
1310      level => $article->{level},
1311      checked => \&tag_checked,
1312      $it->make_iterator
1313      ([ \&iter_get_images, $self, $article ], 'image', 'images', \@images,
1314       \$image_index, undef, \$current_image),
1315      image => [ tag_image => $self, $cfg, \$current_image ],
1316      thumbimage => [ \&tag_thumbimage, $cfg, $thumbs_obj, \$current_image ],
1317      ifThumbs => defined($thumbs_obj),
1318      ifCanThumbs => defined($thumbs_obj_real),
1319      imgmove => [ \&tag_imgmove, $request, $article, \$image_index, \@images ],
1320      message => $msg,
1321      ifError => $if_error,
1322      $ita->make
1323      (
1324       code => [ \&iter_get_kids, $article, $articles ],
1325       single => 'child',
1326       plural => 'children',
1327       data => \@children,
1328       index => \$child_index,
1329      ),
1330      ifchildren => \&tag_if_children,
1331      childtype => [ \&tag_art_type, $article->{level}+1, $cfg ],
1332      ifHaveChildType => [ \&tag_if_have_child_type, $article->{level}, $cfg ],
1333      movechild => [ \&tag_movechild, $self, $request, $article, \@children,
1334                     \$child_index],
1335      is => \&tag_is,
1336      templates => [ \&tag_templates, $self, $article, $cfg, $cgi ],
1337      titleImages => [ \&tag_title_images, $self, $article, $cfg, $cgi ],
1338      editParent => [ \&tag_edit_parent, $article ],
1339      $ita->make
1340      (
1341       code => [ \&iter_allkids, $article ],
1342       single => 'kid',
1343       plural => 'kids',
1344       data => \@allkids,
1345       index => \$allkid_index,
1346      ),
1347      ifStepKid =>
1348      [ \&tag_if_step_kid, $article, \@allkids, \$allkid_index, \%stepkids ],
1349      stepkid => [ \&tag_step_kid, $article, \@allkids, \$allkid_index,
1350                   \%stepkids ],
1351      movestepkid =>
1352      [ \&tag_move_stepkid, $self, $cgi, $request, $article, \@allkids,
1353        \$allkid_index ],
1354      possible_stepkids =>
1355      [ \&tag_possible_stepkids, \%stepkids, $request, $article,
1356        \@possstepkids, $articles, $cgi ],
1357      ifPossibles =>
1358      [ \&tag_if_possible_stepkids, \%stepkids, $request, $article,
1359        \@possstepkids, $articles, $cgi ],
1360      $ita->make
1361      (
1362       code => [ \&iter_get_stepparents, $article ],
1363       single => 'stepparent',
1364       plural => 'stepparents',
1365       data => \@stepparents,
1366       index => \$stepparent_index,
1367      ),
1368      ifStepParents => \&tag_ifStepParents,
1369      stepparent_targ =>
1370      [ \&tag_stepparent_targ, $article, \@stepparent_targs,
1371        \$stepparent_index ],
1372      movestepparent =>
1373      [ \&tag_move_stepparent, $self, $cgi, $request, $article, \@stepparents,
1374        \$stepparent_index ],
1375      ifStepparentPossibles =>
1376      [ \&tag_if_stepparent_possibles, $request, $article, $articles,
1377        \@stepparent_targs, \@stepparentpossibles, ],
1378      stepparent_possibles =>
1379      [ \&tag_stepparent_possibles, $cgi, $request, $article, $articles,
1380        \@stepparent_targs, \@stepparentpossibles, ],
1381      $ito->make
1382      (
1383       code => [ iter_files => $self, $article ],
1384       single => 'file',
1385       plural => 'files',
1386       data => \@files,
1387       index => \$file_index,
1388      ),
1389      movefiles =>
1390      [ \&tag_movefiles, $self, $request, $article, \@files, \$file_index ],
1391      $it->make
1392      (
1393       code => [ iter_file_metas => $self, \@files, \$file_index ],
1394       plural => "file_metas",
1395       single => "file_meta",
1396       nocache => 1,
1397      ),
1398      ifFileExists => sub {
1399        @files && $file_index >= 0 && $file_index < @files
1400          or return 0;
1401
1402        return -f ($files[$file_index]->full_filename($cfg));
1403      },
1404      file_display => [ tag_file_display => $self, \@files, \$file_index ],
1405      DevHelp::Tags->make_iterator2
1406      (\&iter_admin_users, 'iadminuser', 'adminusers'),
1407      DevHelp::Tags->make_iterator2
1408      (\&iter_admin_groups, 'iadmingroup', 'admingroups'),
1409      edit => [ \&tag_edit_link, $cfg, $article ],
1410      error => [ $tag_hash, $errors ],
1411      error_img => [ \&tag_error_img, $cfg, $errors ],
1412      ifFieldPerm => [ \&tag_if_field_perm, $request, $article ],
1413      parent => [ \&tag_article, $parent, $cfg ],
1414      DevHelp::Tags->make_iterator2
1415      ([ \&iter_flags, $self ], 'flag', 'flags' ),
1416      ifFlagSet => [ \&tag_if_flag_set, $article ],
1417      DevHelp::Tags->make_iterator2
1418      ([ \&iter_crumbs, $article, $articles ], 'crumb', 'crumbs' ),
1419      typename => \&tag_typename,
1420      $it->make_iterator([ \&iter_groups, $request ],
1421                         'group', 'groups', \@groups, undef, undef,
1422                         \$current_group),
1423      $it->make_iterator([ iter_image_stores => $self],
1424                         'image_store', 'image_stores'),
1425      $it->make_iterator([ iter_file_stores => $self],
1426                         'file_store', 'file_stores'),
1427      ifGroupRequired => [ \&tag_ifGroupRequired, $article, \$current_group ],
1428      category => [ tag_category => $self, $articles, $article ],
1429      $ito->make
1430      (
1431       single => "tag",
1432       plural => "tags",
1433       code => [ iter_tags => $self, $article ],
1434      ),
1435     );
1436 }
1437
1438 sub iter_image_stores {
1439   my ($self) = @_;
1440
1441   my $mgr = $self->_image_manager;
1442
1443   return map +{ name => $_->name, description => $_->description },
1444     $mgr->all_stores;
1445 }
1446
1447 sub _file_manager {
1448   my ($self) = @_;
1449
1450   require BSE::TB::ArticleFiles;
1451
1452   return BSE::TB::ArticleFiles->file_manager($self->cfg);
1453 }
1454
1455 sub iter_file_stores {
1456   my ($self) = @_;
1457
1458   require BSE::TB::ArticleFiles;
1459   my $mgr = $self->_file_manager($self->cfg);
1460
1461   return map +{ name => $_->name, description => $_->description },
1462     $mgr->all_stores;
1463 }
1464
1465 sub iter_groups {
1466   my ($req) = @_;
1467
1468   require BSE::TB::SiteUserGroups;
1469   BSE::TB::SiteUserGroups->admin_and_query_groups($req->cfg);
1470 }
1471
1472 sub tag_ifGroupRequired {
1473   my ($article, $rgroup) = @_;
1474
1475   $article->{id}
1476     or return 0;
1477
1478   $$rgroup or return 0;
1479
1480   $article->is_accessible_to($$rgroup);
1481 }
1482
1483 sub edit_template {
1484   my ($self, $article, $cgi) = @_;
1485
1486   my $base = $article->{level};
1487   my $t = $cgi->param('_t');
1488   if ($t && $t =~ /^\w+$/) {
1489     $base = $t;
1490   }
1491   return $self->{cfg}->entry('admin templates', $base,
1492                              "admin/edit_$base");
1493 }
1494
1495 sub add_template {
1496   my ($self, $article, $cgi) = @_;
1497
1498   $self->edit_template($article, $cgi);
1499 }
1500
1501 sub low_edit_form {
1502   my ($self, $request, $article, $articles, $msg, $errors) = @_;
1503
1504   my $cgi = $request->cgi;
1505   my %acts;
1506   %acts = $self->low_edit_tags(\%acts, $request, $article, $articles, $msg,
1507                               $errors);
1508   my $template = $article->{id} ?
1509     $self->edit_template($article, $cgi) : $self->add_template($article, $cgi);
1510
1511   return $request->response($template, \%acts);
1512 }
1513
1514 sub edit_form {
1515   my ($self, $request, $article, $articles, $msg, $errors) = @_;
1516
1517   return $self->low_edit_form($request, $article, $articles, $msg, $errors);
1518 }
1519
1520 sub _dummy_article {
1521   my ($self, $req, $articles, $rmsg) = @_;
1522
1523   my $level;
1524   my $cgi = $req->cgi;
1525   my $parentid = $cgi->param('parentid');
1526   if ($parentid) {
1527     if ($parentid =~ /^\d+$/) {
1528       if (my $parent = $self->get_parent($parentid, $articles)) {
1529         $level = $parent->{level}+1;
1530       }
1531       else {
1532         $parentid = undef;
1533       }
1534     }
1535     elsif ($parentid eq "-1") {
1536       $level = 1;
1537     }
1538   }
1539   unless (defined $level) {
1540     $level = $cgi->param('level');
1541     undef $level unless defined $level && $level =~ /^\d+$/
1542       && $level > 0 && $level < 100;
1543     defined $level or $level = 3;
1544   }
1545
1546   my %article;
1547   my @cols = BSE::TB::Article->columns;
1548   @article{@cols} = ('') x @cols;
1549   $article{id} = '';
1550   $article{parentid} = $parentid;
1551   $article{level} = $level;
1552   $article{body} = '<maximum of 64Kb>';
1553   $article{listed} = 1;
1554   $article{generator} = $self->generator;
1555
1556   my ($values, $labels) = $self->possible_parents(\%article, $articles, $req);
1557   unless (@$values) {
1558     $$rmsg = "You can't add children to any article at that level";
1559     return;
1560   }
1561
1562   return $self->_make_dummy_article(\%article);
1563 }
1564
1565 sub _make_dummy_article {
1566   my ($self, $article) = @_;
1567
1568   require BSE::DummyArticle;
1569   return bless $article, "BSE::DummyArticle";
1570 }
1571
1572 sub add_form {
1573   my ($self, $req, $article, $articles, $msg, $errors) = @_;
1574
1575   return $self->low_edit_form($req, $article, $articles, $msg, $errors);
1576 }
1577
1578 sub generator { 'BSE::Generate::Article' }
1579
1580 sub typename {
1581   my ($self) = @_;
1582
1583   my $gen = $self->generator;
1584
1585   ($gen =~ /(\w+)$/)[0] || 'Article';
1586 }
1587
1588 sub _validate_common {
1589   my ($self, $data, $articles, $errors, $article) = @_;
1590
1591 #   if (defined $data->{parentid} && $data->{parentid} =~ /^(?:-1|\d+)$/) {
1592 #     unless ($data->{parentid} == -1 or
1593 #           $articles->getByPkey($data->{parentid})) {
1594 #       $errors->{parentid} = "Selected parent article doesn't exist";
1595 #     }
1596 #   }
1597 #   else {
1598 #     $errors->{parentid} = "You need to select a valid parent";
1599 #   }
1600   if (exists $data->{title} && $data->{title} !~ /\S/) {
1601     $errors->{title} = "Please enter a title";
1602   }
1603
1604   if (exists $data->{template} && $data->{template} =~ /\.\./) {
1605     $errors->{template} = "Please only select templates from the list provided";
1606   }
1607   if (exists $data->{linkAlias}
1608       && length $data->{linkAlias}) {
1609     unless ($data->{linkAlias} =~ /\A[a-zA-Z0-9-_]+\z/
1610             && $data->{linkAlias} =~ /[A-Za-z]/) {
1611       $errors->{linkAlias} = "Link alias must contain only alphanumerics and contain at least one letter";
1612     }
1613   }
1614
1615   if (defined $data->{category}) {
1616     unless (first { $_->{id} eq $data->{category} } $self->categories($articles)) {
1617       $errors->{category} = "msg:bse/admin/edit/category/unknown";
1618     }
1619   }
1620
1621   require DevHelp::Validate;
1622   DevHelp::Validate->import('dh_validate_hash');
1623   dh_validate_hash($data, $errors,
1624                    {
1625                     fields => $self->_custom_fields,
1626                     optional => 1,
1627                     dbh => BSE::DB->single->dbh,
1628                    },
1629                    $self->cfg, ARTICLE_CUSTOM_FIELDS_CFG);
1630 }
1631
1632 sub validate {
1633   my ($self, $data, $articles, $errors) = @_;
1634
1635   $self->_validate_common($data, $articles, $errors);
1636   if (!$errors->{linkAlias} && defined $data->{linkAlias} && length $data->{linkAlias}) {
1637     my $other = $articles->getBy(linkAlias => $data->{linkAlias});
1638     $other
1639       and $errors->{linkAlias} =
1640         "Duplicate link alias - already used by article $other->{id}";
1641   }
1642   custom_class($self->{cfg})
1643     ->article_validate($data, undef, $self->typename, $errors);
1644
1645   return !keys %$errors;
1646 }
1647
1648 sub validate_old {
1649   my ($self, $article, $data, $articles, $errors, $ajax) = @_;
1650
1651   $self->_validate_common($data, $articles, $errors, $article);
1652   custom_class($self->{cfg})
1653     ->article_validate($data, $article, $self->typename, $errors);
1654
1655   if (exists $data->{release}) {
1656     if ($ajax && !dh_parse_sql_date($data->{release})
1657         || !$ajax && !dh_parse_date($data->{release})) {
1658       $errors->{release} = "Invalid release date";
1659     }
1660   }
1661
1662   if (!$errors->{linkAlias}
1663       && defined $data->{linkAlias}
1664       && length $data->{linkAlias}
1665       && $data->{linkAlias} ne $article->{linkAlias}) {
1666     my $other = $articles->getBy(linkAlias => $data->{linkAlias});
1667     $other && $other->{id} != $article->{id}
1668       and $errors->{linkAlias} = "Duplicate link alias - already used by article $other->{id}";
1669   }
1670
1671   return !keys %$errors;
1672 }
1673
1674 sub validate_parent {
1675   1;
1676 }
1677
1678 sub fill_new_data {
1679   my ($self, $req, $data, $articles) = @_;
1680
1681   my $custom = $self->_custom_fields;
1682   for my $key (keys %$custom) {
1683     my ($value) = $req->cgi->param($key);
1684     if (defined $value) {
1685       if ($key =~ /^customDate/) {
1686         require DevHelp::Date;
1687         my $msg;
1688         if (my ($year, $month, $day) =
1689             DevHelp::Date::dh_parse_date($value, \$msg)) {
1690           $data->{$key} = sprintf("%04d-%02d-%02d", $year, $month, $day);
1691         }
1692         else {
1693           $data->{$key} = undef;
1694         }
1695       }
1696       elsif ($key =~ /^customInt/) {
1697         if ($value =~ /\S/) {
1698           $data->{$key} = $value;
1699         }
1700         else {
1701           $data->{$key} = undef;
1702         }
1703       }
1704       else {
1705         $data->{$key} = $value;
1706       }
1707     }
1708   }
1709
1710   custom_class($self->{cfg})
1711     ->article_fill_new($data, $self->typename);
1712
1713   1;
1714 }
1715
1716 sub link_path {
1717   my ($self, $article) = @_;
1718
1719   # check the config for the article and any of its ancestors
1720   my $work_article = $article;
1721   my $path = $self->{cfg}->entry('article uris', $work_article->{id});
1722   while (!$path) {
1723     last if $work_article->{parentid} == -1;
1724     $work_article = $work_article->parent;
1725     $path = $self->{cfg}->entry('article uris', $work_article->{id});
1726   }
1727   return $path if $path;
1728
1729   $self->default_link_path($article);
1730 }
1731
1732 sub default_link_path {
1733   my ($self, $article) = @_;
1734
1735   $self->{cfg}->entry('uri', 'articles', '/a');
1736 }
1737
1738 sub make_link {
1739   my ($self, $article) = @_;
1740
1741   $article->is_linked
1742     or return "";
1743
1744   my $title = $article->title;
1745   if ($article->is_dynamic) {
1746     (my $extra = $title) =~ tr/A-Za-z0-9/-/sc;
1747     return "/cgi-bin/page.pl?page=$article->{id}&title=".escape_uri($extra);
1748   }
1749
1750   my $article_uri = $self->link_path($article);
1751   my $link = "$article_uri/$article->{id}.html";
1752   my $link_titles = $self->{cfg}->entryBool('basic', 'link_titles', 0);
1753   if ($link_titles) {
1754     (my $extra = $title) =~ tr/A-Za-z0-9/-/sc;
1755     $link .= "/" . $extra . "_html";
1756   }
1757
1758   $link;
1759 }
1760
1761 sub save_columns {
1762   my ($self, $table_object) = @_;
1763
1764   my @columns = $table_object->rowClass->columns;
1765   shift @columns;
1766
1767   return @columns;
1768 }
1769
1770 sub _validate_tags {
1771   my ($self, $tags, $errors) = @_;
1772
1773   my $fail = 0;
1774   my @errors;
1775   for my $tag (@$tags) {
1776     my $error;
1777     if ($tag =~ /\S/
1778         && !BSE::TB::Tags->valid_name($tag, \$error)) {
1779       push @errors, "msg:bse/admin/edit/tags/invalid/$error";
1780       $errors->{tags} = \@errors;
1781       ++$fail;
1782     }
1783     else {
1784       push @errors, undef;
1785     }
1786   }
1787
1788   return $fail;
1789 }
1790
1791 sub save_new {
1792   my ($self, $req, $article, $articles) = @_;
1793
1794   $req->check_csrf("admin_add_article")
1795     or return $self->csrf_error($req, undef, "admin_add_article", "Add Article");
1796
1797   my $cgi = $req->cgi;
1798   my %data;
1799   my $table_object = $self->table_object($articles);
1800   my @columns = $self->save_columns($table_object);
1801   $self->save_thumbnail($cgi, undef, \%data);
1802   for my $name (@columns) {
1803     $data{$name} = $cgi->param($name)
1804       if defined $cgi->param($name);
1805   }
1806   $data{flags} = join '', sort $cgi->param('flags');
1807
1808   my $msg;
1809   my %errors;
1810   if (!defined $data{parentid} || $data{parentid} eq '') {
1811     $errors{parentid} = "Please select a parent";
1812   }
1813   elsif ($data{parentid} !~ /^(?:-1|\d+)$/) {
1814     $errors{parentid} = "Invalid parent selection (template bug)";
1815   }
1816   $self->validate(\%data, $articles, \%errors);
1817
1818   my $save_tags = $cgi->param("_save_tags");
1819   my @tags;
1820   if ($save_tags) {
1821     @tags = $cgi->param("tags");
1822     $self->_validate_tags(\@tags, \%errors);
1823   }
1824
1825   my $meta;
1826   if ($cgi->param("_save_meta")) {
1827     require BSE::ArticleMetaMeta;
1828     $meta = BSE::ArticleMetaMeta->retrieve($req, $article, \%errors);
1829   }
1830
1831   if (keys %errors) {
1832     if ($req->is_ajax) {
1833       return $req->json_content
1834         (
1835          success => 0,
1836          errors => \%errors,
1837          error_code => "FIELD",
1838          message => $req->message(\%errors),
1839         );
1840     }
1841     else {
1842       return $self->add_form($req, $article, $articles, $msg, \%errors);
1843     }
1844   }
1845
1846   my $parent;
1847   my $parent_msg;
1848   my $parent_code;
1849   if ($data{parentid} > 0) {
1850     $parent = $articles->getByPkey($data{parentid}) or die;
1851     if ($req->user_can('edit_add_child', $parent)) {
1852       for my $name (@columns) {
1853         if (exists $data{$name} &&
1854             !$req->user_can("edit_add_field_$name", $parent)) {
1855           delete $data{$name};
1856         }
1857       }
1858     }
1859     else {
1860       $parent_msg = "You cannot add a child to that article";
1861       $parent_code = "ACCESS";
1862     }
1863   }
1864   else {
1865     if ($req->user_can('edit_add_child')) {
1866       for my $name (@columns) {
1867         if (exists $data{$name} &&
1868             !$req->user_can("edit_add_field_$name")) {
1869           delete $data{$name};
1870         }
1871       }
1872     }
1873     else {
1874       $parent_msg = "You cannot create a top-level article";
1875       $parent_code = "ACCESS";
1876     }
1877   }
1878   if (!$parent_msg) {
1879     $self->validate_parent(\%data, $articles, $parent, \$parent_msg)
1880       or $parent_code = "PARENT";
1881   }
1882   if ($parent_msg) {
1883     if ($req->is_ajax) {
1884       return $req->json_content
1885         (
1886          success => 0,
1887          message => $parent_msg,
1888          error_code => $parent_code,
1889          errors => {},
1890         );
1891     }
1892     else {
1893       return $self->add_form($req, $article, $articles, $parent_msg);
1894     }
1895   }
1896
1897   my $level = $parent ? $parent->{level}+1 : 1;
1898   $data{level} = $level;
1899   $data{displayOrder} = time;
1900   $data{link} ||= '';
1901   $data{admin} ||= '';
1902   $data{generator} = $self->generator;
1903   $data{lastModified} = now_sqldatetime();
1904   $data{listed} = 1 unless defined $data{listed};
1905
1906 # Added by adrian
1907   $data{pageTitle} = '' unless defined $data{pageTitle};
1908   my $user = $req->getuser;
1909   $data{createdBy} = $user ? $user->{logon} : '';
1910   $data{lastModifiedBy} = $user ? $user->{logon} : '';
1911   $data{created} =  now_sqldatetime();
1912 # end adrian
1913
1914   $data{force_dynamic} = 0;
1915   $data{cached_dynamic} = 0;
1916   $data{inherit_siteuser_rights} = 1;
1917
1918 # Added by adrian
1919   $data{metaDescription} = '' unless defined $data{metaDescription};
1920   $data{metaKeywords} = '' unless defined $data{metaKeywords};
1921 # end adrian
1922
1923   $self->fill_new_data($req, \%data, $articles);
1924   for my $col (qw(titleImage imagePos template keyword menu titleAlias linkAlias body author summary category)) {
1925     defined $data{$col}
1926       or $data{$col} = $self->default_value($req, \%data, $col);
1927   }
1928
1929   for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1930     if ($req->user_can("edit_add_field_$col", $parent)
1931         && $cgi->param("save_$col")) {
1932       $data{$col} = $cgi->param($col) ? 1 : 0;
1933     }
1934     else {
1935       $data{$col} = $self->default_value($req, \%data, $col);
1936     }
1937   }
1938
1939   unless ($req->is_ajax) {
1940     for my $col (qw(release expire)) {
1941       $data{$col} = sql_date($data{$col});
1942     }
1943   }
1944
1945   # these columns are handled a little differently
1946   for my $col (qw(release expire threshold summaryLength )) {
1947     $data{$col}
1948       or $data{$col} = $self->default_value($req, \%data, $col);
1949   }
1950
1951   my @cols = $table_object->rowClass->columns;
1952   shift @cols;
1953
1954   # fill out anything else from defaults
1955   for my $col (@columns) {
1956     exists $data{$col}
1957       or $data{$col} = $self->default_value($req, \%data, $col);
1958   }
1959
1960   $article = $table_object->add(@data{@cols});
1961
1962   $self->save_new_more($req, $article, \%data);
1963
1964   # we now have an id - generate the links
1965
1966   $article->update_dynamic($self->{cfg});
1967   my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
1968   $article->setAdmin("$cgi_uri/admin/admin.pl?id=$article->{id}");
1969   $article->setLink($self->make_link($article));
1970   $article->save();
1971
1972   my ($after_id) = $cgi->param("_after");
1973   if (defined $after_id) {
1974     BSE::TB::Articles->reorder_child($article->{parentid}, $article->{id}, $after_id);
1975     # reload, the displayOrder probably changed
1976     $article = $articles->getByPkey($article->{id});
1977   }
1978
1979   if ($save_tags) {
1980     my $error;
1981     $article->set_tags([ grep /\S/, @tags ], \$error);
1982   }
1983
1984   if ($meta) {
1985     BSE::ArticleMetaMeta->save($article, $meta);
1986   }
1987
1988   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
1989
1990   if ($req->is_ajax) {
1991     return $req->json_content
1992       (
1993        {
1994         success => 1,
1995         article => $self->_article_data($req, $article),
1996        },
1997       );
1998   }
1999
2000   my $r = $cgi->param('r');
2001   if ($r) {
2002     $r .= ($r =~ /\?/) ? '&' : '?';
2003     $r .= "id=$article->{id}";
2004   }
2005   else {
2006     $r = admin_base_url($req->cfg) . $article->{admin};
2007   }
2008   return BSE::Template->get_refresh($r, $self->{cfg});
2009 }
2010
2011 sub fill_old_data {
2012   my ($self, $req, $article, $data) = @_;
2013
2014   if (exists $data->{body}) {
2015     $data->{body} =~ s/\x0D\x0A/\n/g;
2016     $data->{body} =~ tr/\r/\n/;
2017   }
2018   for my $col (BSE::TB::Article->columns) {
2019     next if $col =~ /^custom/;
2020     $article->{$col} = $data->{$col}
2021       if exists $data->{$col} && $col ne 'id' && $col ne 'parentid';
2022   }
2023   my $custom = $self->_custom_fields;
2024   for my $key (keys %$custom) {
2025     if (exists $data->{$key}) {
2026       if ($key =~ /^customDate/) {
2027         require DevHelp::Date;
2028         my $msg;
2029         if (my ($year, $month, $day) =
2030             DevHelp::Date::dh_parse_date($data->{$key}, \$msg)) {
2031           $article->set($key, sprintf("%04d-%02d-%02d", $year, $month, $day));
2032         }
2033         else {
2034           $article->set($key => undef);
2035         }
2036       }
2037       elsif ($key =~ /^customInt/) {
2038         if ($data->{$key} =~ /\S/) {
2039           $article->set($key => $data->{$key});
2040         }
2041         else {
2042           $article->set($key => undef);
2043         }
2044       }
2045       else {
2046         $article->set($key => $data->{$key});
2047       }
2048     }
2049   }
2050   custom_class($self->{cfg})
2051     ->article_fill_old($article, $data, $self->typename);
2052
2053   return 1;
2054 }
2055
2056 sub _article_data {
2057   my ($self, $req, $article) = @_;
2058
2059   my $article_data = $article->data_only;
2060   $article_data->{link} = $article->link($req->cfg);
2061   $article_data->{images} =
2062     [
2063      map $self->_image_data($req->cfg, $_), $article->images
2064     ];
2065   $article_data->{files} =
2066     [
2067      map $_->data_only, $article->files,
2068     ];
2069   $article_data->{tags} =
2070     [
2071      $article->tags, # just the names
2072     ];
2073
2074   return $article_data;
2075 }
2076
2077 sub save_more {
2078   my ($self, $req, $article, $data) = @_;
2079   # nothing to do here
2080 }
2081
2082 sub save_new_more {
2083   my ($self, $req, $article, $data) = @_;
2084   # nothing to do here
2085 }
2086
2087 =item save
2088
2089 Error codes:
2090
2091 =over
2092
2093 =item *
2094
2095 ACCESS - user doesn't have access to this article.
2096
2097 =item *
2098
2099 LASTMOD - lastModified value doesn't match that in the article
2100
2101 =item *
2102
2103 PARENT - invalid parentid specified
2104
2105 =back
2106
2107 =cut
2108
2109 sub save {
2110   my ($self, $req, $article, $articles) = @_;
2111
2112   $req->check_csrf("admin_save_article")
2113     or return $self->csrf_error($req, $article, "admin_save_article", "Save Article");
2114
2115   $req->user_can(edit_save => $article)
2116     or return $self->_service_error
2117       ($req, $article, $articles, "You don't have access to save this article",
2118        {}, "ACCESS");
2119
2120   my $old_dynamic = $article->is_dynamic;
2121   my $cgi = $req->cgi;
2122   my %data;
2123   my $table_object = $self->table_object($articles);
2124   my @save_cols = $self->save_columns($table_object);
2125   for my $name (@save_cols) {
2126     $data{$name} = $cgi->param($name)
2127       if defined($cgi->param($name)) and $name ne 'id' && $name ne 'parentid'
2128         && $req->user_can("edit_field_edit_$name", $article);
2129   }
2130
2131 # Added by adrian
2132 # checks editor lastModified against record lastModified
2133   if ($self->{cfg}->entry('editor', 'check_modified')) {
2134     if ($article->{lastModified} ne $cgi->param('lastModified')) {
2135       my $whoModified = '';
2136       my $timeModified = ampm_time($article->{lastModified});
2137       if ($article->{lastModifiedBy}) {
2138         $whoModified = "by '$article->{lastModifiedBy}'";
2139       }
2140       print STDERR "non-matching lastModified, article not saved\n";
2141       my $msg = "Article changes not saved, this article was modified $whoModified at $timeModified since this editor was loaded";
2142       return $self->_service_error($req, $article, $articles, $msg, {}, "LASTMOD");
2143     }
2144   }
2145 # end adrian
2146
2147   # possibly this needs tighter error checking
2148   $data{flags} = join '', sort $cgi->param('flags')
2149     if $req->user_can("edit_field_edit_flags", $article);
2150   my %errors;
2151   if (exists $article->{template} &&
2152       $article->{template} =~ m|\.\.|) {
2153     $errors{template} = "Please only select templates from the list provided";
2154   }
2155
2156   my $meta;
2157   if ($cgi->param("_save_meta")) {
2158     require BSE::ArticleMetaMeta;
2159     $meta = BSE::ArticleMetaMeta->retrieve($req, $article, \%errors);
2160   }
2161
2162   my $save_tags = $cgi->param("_save_tags");
2163   my @tags;
2164   if ($save_tags) {
2165     @tags = $cgi->param("tags");
2166     $self->_validate_tags(\@tags, \%errors);
2167   }
2168   $self->validate_old($article, \%data, $articles, \%errors, scalar $req->is_ajax)
2169     or return $self->_service_error($req, $article, $articles, undef, \%errors, "FIELD");
2170   $self->save_thumbnail($cgi, $article, \%data)
2171     if $req->user_can('edit_field_edit_thumbImage', $article);
2172   if (exists $data{flags} && $data{flags} =~ /D/) {
2173     $article->remove_html;
2174   }
2175   $self->fill_old_data($req, $article, \%data);
2176
2177   # reparenting
2178   my $newparentid = $cgi->param('parentid');
2179   if ($newparentid
2180       && $req->user_can('edit_field_edit_parentid', $article)
2181       && $newparentid != $article->{parentid}) {
2182     my $newparent;
2183     my $parent_editor;
2184     if ($newparentid == -1) {
2185       require BSE::Edit::Site;
2186       $newparent = BSE::TB::Site->new;
2187       $parent_editor = BSE::Edit::Site->new(cfg => $req->cfg);
2188     }
2189     else {
2190       $newparent = $articles->getByPkey($newparentid);
2191       ($parent_editor, $newparent) = $self->article_class($newparent, $articles, $req->cfg);
2192     }
2193     if ($newparent) {
2194       my $msg;
2195       if ($self->can_reparent_to($article, $newparent, $parent_editor, $articles, \$msg)
2196          && $self->reparent($article, $newparentid, $articles, \$msg)) {
2197         # nothing to do here
2198       }
2199       else {
2200         return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
2201       }
2202     }
2203     else {
2204       return $self->_service_error($req, $article, $articles, "No such parent article", {}, "PARENT");
2205     }
2206   }
2207
2208   $article->{listed} = $cgi->param('listed')
2209    if defined $cgi->param('listed') &&
2210       $req->user_can('edit_field_edit_listed', $article);
2211
2212   if ($req->user_can('edit_field_edit_release', $article)) {
2213     my $release = $cgi->param("release");
2214     if (defined $release && $release =~ /\S/) {
2215       if ($req->is_ajax) {
2216         $article->{release} = $release;
2217       }
2218       else {
2219         $article->{release} = sql_date($release)
2220       }
2221     }
2222   }
2223
2224   $article->{expire} = sql_date($cgi->param('expire')) || $Constants::D_99
2225     if defined $cgi->param('expire') &&
2226       $req->user_can('edit_field_edit_expire', $article);
2227   for my $col (qw/force_dynamic inherit_siteuser_rights/) {
2228     if ($req->user_can("edit_field_edit_$col", $article)
2229         && $cgi->param("save_$col")) {
2230       $article->{$col} = $cgi->param($col) ? 1 : 0;
2231     }
2232   }
2233
2234   $article->mark_modified(actor => $req->getuser || "U");
2235
2236   my @save_group_ids = $cgi->param('save_group_id');
2237   if ($req->user_can('edit_field_edit_group_id')
2238       && @save_group_ids) {
2239     require BSE::TB::SiteUserGroups;
2240     my %groups = map { $_->{id} => $_ }
2241       BSE::TB::SiteUserGroups->admin_and_query_groups($self->{cfg});
2242     my %set = map { $_ => 1 } $cgi->param('group_id');
2243     my %current = map { $_ => 1 } $article->group_ids;
2244
2245     for my $group_id (@save_group_ids) {
2246       $groups{$group_id} or next;
2247       if ($current{$group_id} && !$set{$group_id}) {
2248         $article->remove_group_id($group_id);
2249       }
2250       elsif (!$current{$group_id} && $set{$group_id}) {
2251         $article->add_group_id($group_id);
2252       }
2253     }
2254   }
2255
2256   my $old_link = $article->{link};
2257   # this need to go last
2258   $article->update_dynamic($self->{cfg});
2259   if (!$self->{cfg}->entry('protect link', $article->{id})) {
2260     my $article_uri = $self->make_link($article);
2261     $article->setLink($article_uri);
2262   }
2263
2264   $article->save();
2265
2266   if ($save_tags) {
2267     my $error;
2268     $article->set_tags([ grep /\S/, @tags ], \$error);
2269   }
2270
2271 use Data::Dumper;
2272 print STDERR Dumper($meta);
2273   if ($meta) {
2274     BSE::ArticleMetaMeta->save($article, $meta);
2275   }
2276
2277   # fix the kids too
2278   my @extra_regen;
2279   @extra_regen = $self->update_child_dynamic($article, $articles, $req);
2280
2281   if ($article->is_dynamic || $old_dynamic) {
2282     if (!$old_dynamic and $old_link) {
2283       unlink $article->link_to_filename($self->{cfg}, $old_link);
2284     }
2285     elsif (!$article->is_dynamic) {
2286       unlink $article->cached_filename($self->{cfg});
2287     }
2288   }
2289
2290   my ($after_id) = $cgi->param("_after");
2291   if (defined $after_id) {
2292     BSE::TB::Articles->reorder_child($article->{parentid}, $article->{id}, $after_id);
2293     # reload, the displayOrder probably changed
2294     $article = $articles->getByPkey($article->{id});
2295   }
2296
2297   if ($Constants::AUTO_GENERATE) {
2298     generate_article($articles, $article);
2299     for my $regen_id (@extra_regen) {
2300       my $regen = $articles->getByPkey($regen_id);
2301       BSE::Regen::generate_low($articles, $regen, $self->{cfg});
2302     }
2303   }
2304
2305   $self->save_more($req, $article, \%data);
2306
2307   if ($req->is_ajax) {
2308     return $req->json_content
2309       (
2310        {
2311         success => 1,
2312         article => $self->_article_data($req, $article),
2313        },
2314       );
2315   }
2316
2317   return $self->refresh($article, $cgi, undef, 'Article saved');
2318 }
2319
2320 sub can_reparent_to {
2321   my ($self, $article, $newparent, $parent_editor, $articles, $rmsg) = @_;
2322
2323   my @child_types = $parent_editor->child_types;
2324   if (!grep $_ eq ref $self, @child_types) {
2325     my ($child_type) = (ref $self) =~ /(\w+)$/;
2326     my ($parent_type) = (ref $parent_editor) =~ /(\w+)$/;
2327
2328     $$rmsg = "A $child_type cannot be a child of a $parent_type";
2329     return;
2330   }
2331
2332   # the article cannot become a child of itself or one of it's
2333   # children
2334   if ($article->{id} == $newparent->id
2335       || $self->is_descendant($article->id, $newparent->id, $articles)) {
2336     $$rmsg = "Cannot become a child of itself or of a descendant";
2337     return;
2338   }
2339
2340   my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2341   if ($self->shop_article) { # if this article belongs in the shop
2342     unless ($newparent->id == $shopid
2343             || $self->is_descendant($shopid, $newparent->{id}, $articles)) {
2344       $$rmsg = "This article belongs in the shop";
2345       return;
2346     }
2347   }
2348   else {
2349     if ($newparent->id == $shopid
2350         || $self->is_descendant($shopid, $newparent->id, $articles)) {
2351       $$rmsg = "This article doesn't belong in the shop";
2352       return;
2353     }
2354   }
2355
2356   return 1;
2357 }
2358
2359 sub shop_article { 0 }
2360
2361 sub update_child_dynamic {
2362   my ($self, $article, $articles, $req) = @_;
2363
2364   my $cfg = $req->cfg;
2365   my @stack = $article->children;
2366   my @regen;
2367   while (@stack) {
2368     my $workart = pop @stack;
2369     my $old_dynamic = $workart->is_dynamic; # before update
2370     my $old_link = $workart->{link};
2371     my $editor;
2372     ($editor, $workart) = $self->article_class($workart, $articles, $cfg);
2373
2374     $workart->update_dynamic($cfg);
2375     if ($old_dynamic != $workart->is_dynamic) {
2376       # update the link
2377       if ($article->{link} && !$cfg->entry('protect link', $workart->{id})) {
2378         my $uri = $editor->make_link($workart);
2379         $workart->setLink($uri);
2380
2381         !$old_dynamic && $old_link
2382           and unlink $workart->link_to_filename($cfg, $old_link);
2383         $workart->is_dynamic
2384           or unlink $workart->cached_filename($cfg);
2385       }
2386
2387       # save dynamic cache change and link if that changed
2388       $workart->save;
2389     }
2390     push @stack, $workart->children;
2391     push @regen, $workart->{id};
2392   }
2393
2394   @regen;
2395 }
2396
2397 sub sql_date {
2398   my $str = shift;
2399   my ($year, $month, $day);
2400
2401   # look for a date
2402   if (($day, $month, $year) = ($str =~ m!(\d+)/(\d+)/(\d+)!)) {
2403     $year += 2000 if $year < 100;
2404
2405     return sprintf("%04d-%02d-%02d", $year, $month, $day);
2406   }
2407   return undef;
2408 }
2409
2410 # Added by adrian
2411 # Converts 24hr time to 12hr AM/PM time
2412 sub ampm_time {
2413   my $str = shift;
2414   my ($hour, $minute, $second, $ampm);
2415
2416   # look for a time
2417   if (($hour, $minute, $second) = ($str =~ m!(\d+):(\d+):(\d+)!)) {
2418     if ($hour > 12) {
2419       $hour -= 12;
2420       $ampm = 'PM';
2421     }
2422     else {
2423       $hour = 12 if $hour == 0;
2424       $ampm = 'AM';
2425     }
2426     return sprintf("%02d:%02d:%02d $ampm", $hour, $minute, $second);
2427   }
2428   return undef;
2429 }
2430 # end adrian
2431
2432 sub reparent {
2433   my ($self, $article, $newparentid, $articles, $rmsg) = @_;
2434
2435   my $newlevel;
2436   if ($newparentid == -1) {
2437     $newlevel = 1;
2438   }
2439   else {
2440     my $parent = $articles->getByPkey($newparentid);
2441     unless ($parent) {
2442       $$rmsg = "Cannot get new parent article";
2443       return;
2444     }
2445     $newlevel = $parent->{level} + 1;
2446   }
2447   # the caller will save this one
2448   $article->{parentid} = $newparentid;
2449   $article->{level} = $newlevel;
2450   $article->{displayOrder} = time;
2451
2452   my @change = ( [ $article->{id}, $newlevel ] );
2453   while (@change) {
2454     my $this = shift @change;
2455     my ($art, $level) = @$this;
2456
2457     my @kids = $articles->getBy(parentid=>$art);
2458     push @change, map { [ $_->{id}, $level+1 ] } @kids;
2459
2460     for my $kid (@kids) {
2461       $kid->{level} = $level+1;
2462       $kid->save;
2463     }
2464   }
2465
2466   return 1;
2467 }
2468
2469 # tests if $desc is a descendant of $art
2470 # where both are article ids
2471 sub is_descendant {
2472   my ($self, $art, $desc, $articles) = @_;
2473
2474   my @check = ($art);
2475   while (@check) {
2476     my $parent = shift @check;
2477     $parent == $desc and return 1;
2478     my @kids = $articles->getBy(parentid=>$parent);
2479     push @check, map $_->{id}, @kids;
2480   }
2481
2482   return 0;
2483 }
2484
2485 sub save_thumbnail {
2486   my ($self, $cgi, $original, $newdata) = @_;
2487
2488   unless ($original) {
2489     @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2490   }
2491   my $imagedir = cfg_image_dir($self->{cfg});
2492   if ($cgi->param('remove_thumb') && $original && $original->{thumbImage}) {
2493     unlink("$imagedir/$original->{thumbImage}");
2494     @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2495   }
2496   my $image_name = $cgi->param('thumbnail');
2497   my $image = $cgi->upload('thumbnail');
2498   if ($image_name && -s $image) {
2499     # where to put it...
2500     my $name = '';
2501     $image_name =~ /([\w.-]+)$/ and $name = $1;
2502     my $filename = time . "_" . $name;
2503
2504     use Fcntl;
2505     my $counter = "";
2506     $filename = time . '_' . $counter . '_' . $name
2507       until sysopen( OUTPUT, "$imagedir/$filename",
2508                      O_WRONLY| O_CREAT| O_EXCL)
2509         || ++$counter > 100;
2510
2511     fileno(OUTPUT) or die "Could not open image file: $!";
2512     binmode OUTPUT;
2513     my $buffer;
2514
2515     #no strict 'refs';
2516
2517     # read the image in from the browser and output it to our
2518     # output filehandle
2519     print STDERR "\$image ",ref $image,"\n";
2520     seek $image, 0, 0;
2521     print OUTPUT $buffer while sysread $image, $buffer, 1024;
2522
2523     close OUTPUT
2524       or die "Could not close image output file: $!";
2525
2526     require BSE::ImageSize;
2527
2528     if ($original && $original->{thumbImage}) {
2529       #unlink("$imagedir/$original->{thumbImage}");
2530     }
2531     @$newdata{qw/thumbWidth thumbHeight/} =
2532       BSE::ImageSize::imgsize("$imagedir/$filename");
2533     $newdata->{thumbImage} = $filename;
2534   }
2535 }
2536
2537 sub child_types {
2538   my ($self, $article) = @_;
2539
2540   my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2541   if ($article && $article->{id} && $article->{id} == $shopid) {
2542     return ( 'BSE::Edit::Catalog' );
2543   }
2544   return ( 'BSE::Edit::Article' );
2545 }
2546
2547 =item add_stepkid
2548
2549 Add a step child to an article.
2550
2551 Parameters:
2552
2553 =over
2554
2555 =item *
2556
2557 id - parent article id (required)
2558
2559 =item *
2560
2561 stepkid - child article id (required)
2562
2563 =item *
2564
2565 _after - id of the allkid of id to position the stepkid after
2566 (optional)
2567
2568 =back
2569
2570 Returns a FIELD error for an invalid stepkid.
2571
2572 Returns an ACCESS error for insufficient access.
2573
2574 Return an ADD error for a general add failure.
2575
2576 On success returns:
2577
2578   {
2579    success: 1,
2580    relationship: { childId: I<childid>, parentId: I<parentid> }
2581   }
2582
2583 =back
2584
2585 =cut
2586
2587 sub add_stepkid {
2588   my ($self, $req, $article, $articles) = @_;
2589
2590   $req->check_csrf("admin_add_stepkid")
2591     or return $self->csrf_error($req, $article, "admin_add_stepkid", "Add Stepkid");
2592
2593   $req->user_can(edit_stepkid_add => $article)
2594     or return $self->_service_error($req, $article, $articles,
2595                                "You don't have access to add step children to this article", {}, "ACCESS");
2596
2597   my $cgi = $req->cgi;
2598   require BSE::Admin::StepParents;
2599
2600   my %errors;
2601   my $childId = $cgi->param('stepkid');
2602   defined $childId
2603     or $errors{stepkid} = "No stepkid supplied to add_stepkid";
2604   unless ($errors{stepkid}) {
2605     $childId =~ /^\d+$/
2606       or $errors{stepkid} = "Invalid stepkid supplied to add_stepkid";
2607   }
2608   my $child;
2609   unless ($errors{stepkid}) {
2610     $child = $articles->getByPkey($childId)
2611       or $errors{stepkid} = "Article $childId not found";
2612   }
2613   keys %errors
2614     and return $self->_service_error
2615       ($req, $article, $articles, $errors{stepkid}, \%errors, "FIELD");
2616
2617   $req->user_can(edit_stepparent_add => $child)
2618     or return $self->_service_error($req, $article, $articles, "You don't have access to add a stepparent to that article", {}, "ACCESS");
2619
2620   my $new_entry;
2621   eval {
2622
2623     my $release = $cgi->param('release');
2624     dh_parse_date($release) or $release = undef;
2625     my $expire = $cgi->param('expire');
2626     dh_parse_date($expire) or $expire = undef;
2627
2628     $new_entry =
2629       BSE::Admin::StepParents->add($article, $child, $release, $expire);
2630   };
2631   if ($@) {
2632     return $self->_service_error($req, $article, $articles, $@, {}, "ADD");
2633   }
2634
2635   my $after_id = $cgi->param("_after");
2636   if (defined $after_id) {
2637     BSE::TB::Articles->reorder_child($article->id, $child->id, $after_id);
2638   }
2639
2640   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2641
2642   if ($req->is_ajax) {
2643     return $req->json_content
2644       (
2645        success => 1,
2646        relationship => $new_entry->data_only,
2647       );
2648   }
2649   else {
2650     $self->refresh($article, $cgi, 'step', 'Stepchild added');
2651   }
2652 }
2653
2654 =item del_stepkid
2655
2656 Remove a stepkid relationship.
2657
2658 Parameters:
2659
2660 =over
2661
2662 =item *
2663
2664 id - parent article id (required)
2665
2666 =item *
2667
2668 stepkid - child article id (required)
2669
2670 =back
2671
2672 Returns a FIELD error for an invalid stepkid.
2673
2674 Returns an ACCESS error for insufficient access.
2675
2676 Return a DELETE error for a general delete failure.
2677
2678 =cut
2679
2680 sub del_stepkid {
2681   my ($self, $req, $article, $articles) = @_;
2682
2683   $req->check_csrf("admin_remove_stepkid")
2684     or return $self->csrf_error($req, $article, "admin_del_stepkid", "Delete Stepkid");
2685   $req->user_can(edit_stepkid_delete => $article)
2686     or return $self->_service_error($req, $article, $articles,
2687                                "You don't have access to delete stepchildren from this article", {}, "ACCESS");
2688
2689   my $cgi = $req->cgi;
2690
2691   my %errors;
2692   my $childId = $cgi->param('stepkid');
2693   defined $childId
2694     or $errors{stepkid} = "No stepkid supplied to add_stepkid";
2695   unless ($errors{stepkid}) {
2696     $childId =~ /^\d+$/
2697       or $errors{stepkid} = "Invalid stepkid supplied to add_stepkid";
2698   }
2699   my $child;
2700   unless ($errors{stepkid}) {
2701     $child = $articles->getByPkey($childId)
2702       or $errors{stepkid} = "Article $childId not found";
2703   }
2704   keys %errors
2705     and return $self->_service_error
2706       ($req, $article, $articles, $errors{stepkid}, \%errors, "FIELD");
2707
2708   $req->user_can(edit_stepparent_delete => $child)
2709     or return _service_error($req, $article, $article, "You cannot remove stepparents from that article", {}, "ACCESS");
2710
2711
2712   require BSE::Admin::StepParents;
2713   eval {
2714     BSE::Admin::StepParents->del($article, $child);
2715   };
2716
2717   if ($@) {
2718     return $self->_service_error($req, $article, $articles, $@, {}, "DELETE");
2719   }
2720   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2721
2722   if ($req->is_ajax) {
2723     return $req->json_content(success => 1);
2724   }
2725   else {
2726     return $self->refresh($article, $cgi, 'step', 'Stepchild deleted');
2727   }
2728 }
2729
2730 sub save_stepkids {
2731   my ($self, $req, $article, $articles) = @_;
2732
2733   $req->check_csrf("admin_save_stepkids")
2734     or return $self->csrf_error($req, $article, "admin_save_stepkids", "Save Stepkids");
2735
2736   $req->user_can(edit_stepkid_save => $article)
2737     or return $self->edit_form($req, $article, $articles,
2738                                "No access to save stepkid data for this article");
2739
2740   my $cgi = $req->cgi;
2741   require 'BSE/Admin/StepParents.pm';
2742   my @stepcats = BSE::TB::OtherParents->getBy(parentId=>$article->{id});
2743   my %stepcats = map { $_->{parentId}, $_ } @stepcats;
2744   my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2745   for my $stepcat (@stepcats) {
2746     $req->user_can(edit_stepparent_save => $stepcat->{childId})
2747       or next;
2748     for my $name (qw/release expire/) {
2749       my $date = $cgi->param($name.'_'.$stepcat->{childId});
2750       if (defined $date) {
2751         if ($date eq '') {
2752           $date = $datedefs{$name};
2753         }
2754         elsif (dh_parse_date($date)) {
2755           use BSE::Util::SQL qw/date_to_sql/;
2756           $date = date_to_sql($date);
2757         }
2758         else {
2759           return $self->refresh($article, $cgi, '', "Invalid date '$date'");
2760         }
2761         $stepcat->{$name} = $date;
2762       }
2763     }
2764     eval {
2765       $stepcat->save();
2766     };
2767     $@ and return $self->refresh($article, $cgi, '', $@);
2768   }
2769   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2770
2771   return $self->refresh($article, $cgi, 'step', 'Stepchild information saved');
2772 }
2773
2774 =item a_restepkid
2775
2776 Moves a stepkid from one parent to another, and sets the order within
2777 that new stepparent.
2778
2779 Parameters:
2780
2781 =over
2782
2783 =item *
2784
2785 id - id of the step kid to move (required)
2786
2787 =item *
2788
2789 parentid - id of the parent in the stepkid relationship (required)
2790
2791 =item *
2792
2793 newparentid - the new parent for the stepkid relationship (optional)
2794
2795 =item *
2796
2797 _after - id of the allkid under newparentid (or parentid if
2798 newparentid isn't supplied) to place the stepkid after (0 to place at
2799 the start)
2800
2801 =back
2802
2803 Errors:
2804
2805 =over
2806
2807 =item *
2808
2809 NOPARENTID - parentid parameter not supplied
2810
2811 =item *
2812
2813 BADPARENTID - non-numeric parentid supplied
2814
2815 =item *
2816
2817 NOTFOUND - no stepkid relationship from parentid was found
2818
2819 =item *
2820
2821 BADNEWPARENT - newparentid is non-numeric
2822
2823 =item *
2824
2825 UNKNOWNNEWPARENT - no article id newparentid found
2826
2827 =item *
2828
2829 NEWPARENTDUP - there's already a stepkid relationship between
2830 newparentid and id.
2831
2832 =back
2833
2834 =cut
2835
2836 sub req_restepkid {
2837   my ($self, $req, $article, $articles) = @_;
2838
2839   # first, identify the stepkid link
2840   my $cgi = $req->cgi;
2841   require BSE::TB::OtherParents;
2842   my $parentid = $cgi->param("parentid");
2843   defined $parentid
2844     or return $self->_service_error($req, $article, $articles, "Missing parentid", {}, "NOPARENTID");
2845   $parentid =~ /^\d+$/
2846     or return $self->_service_error($req, $article, $articles, "Invalid parentid", {}, "BADPARENTID");
2847
2848   my ($step) = BSE::TB::OtherParents->getBy(parentId => $parentid, childId => $article->id)
2849     or return $self->_service_error($req, $article, $articles, "Unknown relationship", {}, "NOTFOUND");
2850
2851   my $newparentid = $cgi->param("newparentid");
2852   if ($newparentid) {
2853     $newparentid =~ /^\d+$/
2854       or return $self->_service_error($req, $article, $articles, "Bad new parent id", {}, "BADNEWPARENT");
2855     my $new_parent = BSE::TB::Articles->getByPkey($newparentid)
2856       or return $self->_service_error($req, $article, $articles, "Unknown new parent id", {}, "UNKNOWNNEWPARENT");
2857     my $existing =
2858       BSE::TB::OtherParents->getBy(parentId=>$newparentid, childId=>$article->id)
2859         and return $self->_service_error($req, $article, $articles, "New parent is duplicate", {}, "NEWPARENTDUP");
2860
2861     $step->{parentId} = $newparentid;
2862     $step->save;
2863   }
2864
2865   my $after_id = $cgi->param("_after");
2866   if (defined $after_id) {
2867     BSE::TB::Articles->reorder_child($step->{parentId}, $article->id, $after_id);
2868   }
2869
2870   if ($req->is_ajax) {
2871     return $req->json_content
2872       (
2873        success => 1,
2874        relationshop => $step->data_only,
2875       );
2876   }
2877   else {
2878     return $self->refresh($article, $cgi, 'step', "Stepchild moved");
2879   }
2880 }
2881
2882 sub add_stepparent {
2883   my ($self, $req, $article, $articles) = @_;
2884
2885   $req->check_csrf("admin_add_stepparent")
2886     or return $self->csrf_error($req, $article, "admin_add_stepparent", "Add Stepparent");
2887
2888   $req->user_can(edit_stepparent_add => $article)
2889     or return $self->edit_form($req, $article, $articles,
2890                                "You don't have access to add stepparents to this article");
2891
2892   my $cgi = $req->cgi;
2893   require 'BSE/Admin/StepParents.pm';
2894   eval {
2895     my $step_parent_id = $cgi->param('stepparent');
2896     defined($step_parent_id)
2897       or die "No stepparent supplied to add_stepparent";
2898     int($step_parent_id) eq $step_parent_id
2899       or die "Invalid stepcat supplied to add_stepcat";
2900     my $step_parent = $articles->getByPkey($step_parent_id)
2901       or die "Parent $step_parent_id not found\n";
2902
2903     $req->user_can(edit_stepkid_add => $step_parent)
2904       or die "You don't have access to add a stepkid to that article\n";
2905
2906     my $release = $cgi->param('release');
2907     defined $release
2908       or $release = "01/01/2000";
2909     $release eq '' or dh_parse_date($release)
2910       or die "Invalid release date";
2911     my $expire = $cgi->param('expire');
2912     defined $expire
2913       or $expire = '31/12/2999';
2914     $expire eq '' or dh_parse_date($expire)
2915       or die "Invalid expire data";
2916
2917     my $newentry =
2918       BSE::Admin::StepParents->add($step_parent, $article, $release, $expire);
2919   };
2920   $@ and return $self->refresh($article, $cgi, 'step', $@);
2921
2922   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2923
2924   return $self->refresh($article, $cgi, 'stepparents', 'Stepparent added');
2925 }
2926
2927 sub del_stepparent {
2928   my ($self, $req, $article, $articles) = @_;
2929
2930   $req->check_csrf("admin_remove_stepparent")
2931     or return $self->csrf_error($req, $article, "admin_del_stepparent", "Delete Stepparent");
2932
2933   $req->user_can(edit_stepparent_delete => $article)
2934     or return $self->edit_form($req, $article, $articles,
2935                                "You cannot remove stepparents from that article");
2936
2937   my $cgi = $req->cgi;
2938   require 'BSE/Admin/StepParents.pm';
2939   my $step_parent_id = $cgi->param('stepparent');
2940   defined($step_parent_id)
2941     or return $self->refresh($article, $cgi, 'stepparents',
2942                              "No stepparent supplied to add_stepcat");
2943   int($step_parent_id) eq $step_parent_id
2944     or return $self->refresh($article, $cgi, 'stepparents',
2945                              "Invalid stepparent supplied to add_stepparent");
2946   my $step_parent = $articles->getByPkey($step_parent_id)
2947     or return $self->refresh($article, $cgi, 'stepparent',
2948                              "Stepparent $step_parent_id not found");
2949
2950   $req->user_can(edit_stepkid_delete => $step_parent)
2951     or die "You don't have access to remove the stepkid from that article\n";
2952
2953   eval {
2954     BSE::Admin::StepParents->del($step_parent, $article);
2955   };
2956   $@ and return $self->refresh($article, $cgi, 'stepparents', $@);
2957
2958   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2959
2960   return $self->refresh($article, $cgi, 'stepparents', 'Stepparent deleted');
2961 }
2962
2963 sub save_stepparents {
2964   my ($self, $req, $article, $articles) = @_;
2965
2966   $req->check_csrf("admin_save_stepparents")
2967     or return $self->csrf_error($req, $article, "admin_save_stepparents", "Save Stepparents");
2968   $req->user_can(edit_stepparent_save => $article)
2969     or return $self->edit_form($req, $article, $articles,
2970                                "No access to save stepparent data for this artice");
2971
2972   my $cgi = $req->cgi;
2973
2974   require 'BSE/Admin/StepParents.pm';
2975   my @stepparents = BSE::TB::OtherParents->getBy(childId=>$article->{id});
2976   my %stepparents = map { $_->{parentId}, $_ } @stepparents;
2977   my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2978   for my $stepparent (@stepparents) {
2979     $req->user_can(edit_stepkid_save => $stepparent->{parentId})
2980       or next;
2981     for my $name (qw/release expire/) {
2982       my $date = $cgi->param($name.'_'.$stepparent->{parentId});
2983       if (defined $date) {
2984         if ($date eq '') {
2985           $date = $datedefs{$name};
2986         }
2987         elsif (dh_parse_date($date)) {
2988           use BSE::Util::SQL qw/date_to_sql/;
2989           $date = date_to_sql($date);
2990         }
2991         else {
2992           return $self->refresh($article, $cgi, "Invalid date '$date'");
2993         }
2994         $stepparent->{$name} = $date;
2995       }
2996     }
2997     eval {
2998       $stepparent->save();
2999     };
3000     $@ and return $self->refresh($article, $cgi, '', $@);
3001   }
3002
3003   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3004
3005   return $self->refresh($article, $cgi, 'stepparents',
3006                         'Stepparent information saved');
3007 }
3008
3009 sub refresh_url {
3010   my ($self, $article, $cgi, $name, $message, $extras) = @_;
3011
3012   my $url = $cgi->param('r');
3013   if ($url) {
3014     if ($url !~ /[?&](m|message)=/ && $message) {
3015       # add in messages if none in the provided refresh
3016       my @msgs = ref $message ? @$message : $message;
3017       my $sep = $url =~ /\?/ ? "&" : "?";
3018       for my $msg (@msgs) {
3019         $url .= $sep . "m=" . CGI::escape($msg);
3020       }
3021     }
3022   }
3023   else {
3024     my $urlbase = admin_base_url($self->{cfg});
3025     $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
3026     if ($message) {
3027       my @msgs = ref $message ? @$message : $message;
3028       for my $msg (@msgs) {
3029         $url .= "&m=" . CGI::escape($msg);
3030       }
3031     }
3032     if ($cgi->param('_t')) {
3033       $url .= "&_t=".CGI::escape($cgi->param('_t'));
3034     }
3035     $url .= $extras if defined $extras;
3036     my $cgiextras = $cgi->param('e');
3037     $url .= "#$name" if $name;
3038   }
3039
3040   return $url;
3041 }
3042
3043 sub refresh {
3044   my ($self, $article, $cgi, $name, $message, $extras) = @_;
3045
3046   my $url = $self->refresh_url($article, $cgi, $name, $message, $extras);
3047
3048   return BSE::Template->get_refresh($url, $self->{cfg});
3049 }
3050
3051 sub show_images {
3052   my ($self, $req, $article, $articles, $msg, $errors) = @_;
3053
3054   my %acts;
3055   %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
3056   my $template = 'admin/article_img';
3057
3058   return $req->dyn_response($template, \%acts);
3059 }
3060
3061 sub save_image_changes {
3062   my ($self, $req, $article, $articles) = @_;
3063
3064   $req->check_csrf("admin_save_images")
3065     or return $self->csrf_error($req, $article, "admin_save_images", "Save Images");
3066
3067   $req->user_can(edit_images_save => $article)
3068     or return $self->edit_form($req, $article, $articles,
3069                                  "You don't have access to save image information for this article");
3070
3071   my $image_dir = cfg_image_dir($req->cfg);
3072
3073   my $cgi = $req->cgi;
3074   my $image_pos = $cgi->param('imagePos');
3075   if ($image_pos
3076       && $image_pos =~ /^(?:tl|tr|bl|br|xx)$/
3077       && $image_pos ne $article->{imagePos}) {
3078     $article->{imagePos} = $image_pos;
3079     $article->save;
3080   }
3081   my @images = $self->get_images($article);
3082
3083   @images or
3084     return $self->refresh($article, $cgi, undef, 'No images to save information for');
3085
3086   my %changes;
3087   my %errors;
3088   my %names;
3089   my %old_images;
3090   my @new_images;
3091   for my $image (@images) {
3092     my $id = $image->{id};
3093
3094     my $alt = $cgi->param("alt$id");
3095     if ($alt ne $image->{alt}) {
3096       $changes{$id}{alt} = $alt;
3097     }
3098
3099     my $url = $cgi->param("url$id");
3100     if (defined $url && $url ne $image->{url}) {
3101       $changes{$id}{url} = $url;
3102     }
3103
3104     my $name = $cgi->param("name$id");
3105     if (defined $name && $name ne $image->{name}) {
3106       if ($name eq '') {
3107         $changes{$id}{name} = '';
3108       }
3109       elsif ($name =~ /^[a-z_]\w*$/i) {
3110         my $msg;
3111         if ($self->validate_image_name($name, \$msg)) {
3112           # check for duplicates after the loop
3113           push @{$names{lc $name}}, $image->{id}
3114             if length $name;
3115           $changes{$id}{name} = $name;
3116         }
3117         else {
3118           $errors{"name$id"} = $msg;
3119         }
3120       }
3121       else {
3122         $errors{"name$id"} = 'Image name must be empty or alphanumeric and unique to the article';
3123       }
3124     }
3125     else {
3126       push @{$names{lc $image->{name}}}, $image->{id}
3127         if length $image->{name};
3128     }
3129
3130     my $filename = $cgi->param("image$id");
3131     if (defined $filename && length $filename) {
3132       my $in_fh = $cgi->upload("image$id");
3133       if ($in_fh) {
3134         my $basename;
3135         my $image_error;
3136         my ($width, $height, $type) = $self->_validate_image
3137           ($filename, $in_fh, \$basename, \$image_error);
3138
3139         unless ($type) {
3140           $errors{"image$id"} = $image_error;
3141         }
3142
3143         unless ($errors{"image$id"}) {
3144           # work out where to put it
3145           require DevHelp::FileUpload;
3146           my $msg;
3147           my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3148             ($image_dir, $basename, \$msg);
3149           if ($image_name) {
3150             local $/ = \8192;
3151             my $data;
3152             while ($data = <$in_fh>) {
3153               print $out_fh $data;
3154             }
3155             close $out_fh;
3156
3157             my $full_filename = "$image_dir/$image_name";
3158             if ($width) {
3159               $old_images{$id} =
3160                 {
3161                  image => $image->{image},
3162                  storage => $image->{storage}
3163                 };
3164               push @new_images, $image_name;
3165
3166               $changes{$id}{image} = $image_name;
3167               $changes{$id}{storage} = 'local';
3168               $changes{$id}{src} = cfg_image_uri() . "/" . $image_name;
3169               $changes{$id}{width} = $width;
3170               $changes{$id}{height} = $height;
3171               $changes{$id}{ftype} = $self->_image_ftype($type);
3172             }
3173           }
3174           else {
3175             $errors{"image$id"} = $msg;
3176           }
3177         }
3178       }
3179       else {
3180         # problem uploading
3181         $errors{"image$id"} = "No image file received";
3182       }
3183     }
3184   }
3185   # look for duplicate names
3186   for my $name (keys %names) {
3187     if (@{$names{$name}} > 1) {
3188       for my $id (@{$names{$name}}) {
3189         $errors{"name$id"} = 'Image name must be unique to the article';
3190       }
3191     }
3192   }
3193   if (keys %errors) {
3194     # remove files that won't be stored because validation failed
3195     unlink map "$image_dir/$_", @new_images;
3196
3197     return $self->edit_form($req, $article, $articles, undef,
3198                             \%errors);
3199   }
3200
3201   my $mgr = $self->_image_manager($req->cfg);
3202   $req->flash('Image information saved');
3203   my $changes_found = 0;
3204   my $auto_store = $cgi->param('auto_storage');
3205   for my $image (@images) {
3206     my $id = $image->{id};
3207
3208     if ($changes{$id}) {
3209       my $changes = $changes{$id};
3210       ++$changes_found;
3211
3212       for my $field (keys %$changes) {
3213         $image->{$field} = $changes->{$field};
3214       }
3215       $image->save;
3216     }
3217
3218     my $old_storage = $image->{storage};
3219     my $new_storage = $auto_store ? '' : $cgi->param("storage$id");
3220     defined $new_storage or $new_storage = $image->{storage};
3221     $new_storage = $mgr->select_store($image->{image}, $new_storage, $image);
3222     if ($new_storage ne $old_storage) {
3223       eval {
3224         $image->{src} = $mgr->store($image->{image}, $new_storage, $image);
3225         $image->{storage} = $new_storage;
3226         $image->save;
3227       };
3228
3229       if ($old_storage ne 'local') {
3230         $mgr->unstore($image->{image}, $old_storage);
3231       }
3232     }
3233   }
3234
3235   # delete any image files that were replaced
3236   for my $old_image (values %old_images) {
3237     my ($image, $storage) = @$old_image{qw/image storage/};
3238     if ($storage ne 'local') {
3239       $mgr->unstore($image->{image}, $storage);
3240     }
3241     unlink "$image_dir/$image";
3242   }
3243
3244   if ($changes_found) {
3245     generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3246   }
3247
3248   return $self->refresh($article, $cgi);
3249 }
3250
3251 =item _service_error
3252
3253 This function is called on various errors.
3254
3255 If a _service parameter was supplied, returns text like:
3256
3257 =over
3258
3259 Result: failure
3260
3261 Field-Error: I<field-name1> - I<message1>
3262
3263 Field-Error: I<field-name2> - I<message2>
3264
3265 =back
3266
3267 If the request is detected as an ajax request or a _ parameter is
3268 supplied, return JSON like:
3269
3270   { error: I<message> }
3271
3272 Otherwise display the normal edit page with the error.
3273
3274 =cut
3275
3276 sub _service_error {
3277   my ($self, $req, $article, $articles, $msg, $error, $code, $method) = @_;
3278
3279   unless ($article) {
3280     my $mymsg;
3281     $article = $self->_dummy_article($req, $articles, \$mymsg);
3282     $article ||=
3283       {
3284        map $_ => '', BSE::TB::Article->columns
3285       };
3286   }
3287
3288   if ($req->cgi->param('_service')) {
3289     my $body = '';
3290     $body .= "Result: failure\n";
3291     if (ref $error) {
3292       for my $field (keys %$error) {
3293         my $text = $error->{$field};
3294         $text =~ tr/\n/ /;
3295         $body .= "Field-Error: $field - $text\n";
3296       }
3297       my $text = join ('/', values %$error);
3298       $text =~ tr/\n/ /;
3299       $body .= "Error: $text\n";
3300     }
3301     elsif ($msg) {
3302       $body .= "Error: $msg\n";
3303     }
3304     else {
3305       $body .= "Error: $error\n";
3306     }
3307     return
3308       {
3309        type => 'text/plain',
3310        content => $body,
3311       };
3312   }
3313   elsif ((() = $req->cgi->param('_')) ||
3314          (exists $ENV{HTTP_X_REQUESTED_WITH}
3315           && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/)) {
3316     $error ||= {};
3317     my $result =
3318       {
3319        errors => $error,
3320        success => 0,
3321       };
3322     $msg and $result->{message} = $msg;
3323     $code and $result->{error_code} = $code;
3324     my $json_result = $req->json_content($result);
3325
3326     if (!exists $ENV{HTTP_X_REQUESTED_WITH}
3327         || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
3328       $json_result->{type} = "text/plain";
3329     }
3330
3331     return $json_result;
3332   }
3333   else {
3334     $method ||= "edit_form";
3335     return $self->$method($req, $article, $articles, $msg, $error);
3336   }
3337 }
3338
3339 sub _service_success {
3340   my ($self, $results) = @_;
3341
3342   my $body = "Result: success\n";
3343   for my $field (keys %$results) {
3344     $body .= "$field: $results->{$field}\n";
3345   }
3346   return
3347     {
3348      type => 'text/plain',
3349      content => $body,
3350     };
3351 }
3352
3353 # FIXME: eliminate this method and call get_ftype directly
3354 sub _image_ftype {
3355   my ($self, $type) = @_;
3356
3357   require BSE::TB::Images;
3358   return BSE::TB::Images->get_ftype($type);
3359 }
3360
3361 my %valid_exts =
3362   (
3363    tiff => "tiff,tif",
3364    jpg => "jpeg,jpg",
3365    pnm => "pbm,pgm,ppm",
3366   );
3367
3368 sub _validate_image {
3369   my ($self, $filename, $fh, $rbasename, $error) = @_;
3370
3371   if ($fh) {
3372     if (-z $fh) {
3373       $$error = 'Image file is empty';
3374       return;
3375     }
3376   }
3377   else {
3378     $$error = 'Please enter an image filename';
3379     return;
3380   }
3381   my $imagename = $filename;
3382   $imagename .= ''; # force it into a string
3383   (my $basename = $imagename) =~ tr/A-Za-z0-9_./-/cs;
3384
3385   require BSE::ImageSize;
3386
3387   my ($width,$height, $type) = BSE::ImageSize::imgsize($fh);
3388
3389   unless (defined $width) {
3390     $$error = "Unknown image file type";
3391     return;
3392   }
3393
3394   my $lctype = lc $type;
3395   my @valid_exts = split /,/,
3396     BSE::Cfg->single->entry("valid image extensions", $lctype,
3397                 $valid_exts{$lctype} || $lctype);
3398
3399   my ($ext) = $basename =~ /\.(\w+)\z/;
3400   if (!$ext || !grep $_ eq lc $ext, @valid_exts) {
3401     $basename .= ".$valid_exts[0]";
3402   }
3403   $$rbasename = $basename;
3404
3405   return ($width, $height, $type);
3406 }
3407
3408 my $last_display_order = 0;
3409
3410 sub do_add_image {
3411   my ($self, $cfg, $article, $image, %opts) = @_;
3412
3413   my $errors = $opts{errors}
3414     or die "No errors parameter";
3415
3416   my $imageref = $opts{name};
3417   if (defined $imageref && $imageref ne '') {
3418     if ($imageref =~ /^[a-z_]\w+$/i) {
3419       # make sure it's unique
3420       my @images = $self->get_images($article);
3421       for my $img (@images) {
3422         if (defined $img->{name} && lc $img->{name} eq lc $imageref) {
3423           $errors->{name} = 'Image name must be unique to the article';
3424           last;
3425         }
3426       }
3427     }
3428     else {
3429       $errors->{name} = 'Image name must be empty or alphanumeric beginning with an alpha character';
3430     }
3431   }
3432   else {
3433     $imageref = '';
3434   }
3435   unless ($errors->{name}) {
3436     my $workmsg;
3437     $self->validate_image_name($imageref, \$workmsg)
3438       or $errors->{name} = $workmsg;
3439   }
3440
3441   my $image_error;
3442   my $basename;
3443   my ($width, $height, $type) =
3444     $self->_validate_image($opts{filename} || $image, $image, \$basename,
3445                            \$image_error);
3446   unless ($width) {
3447     $errors->{image} = $image_error;
3448   }
3449
3450   keys %$errors
3451     and return;
3452
3453   # for the sysopen() constants
3454   use Fcntl;
3455
3456   my $imagedir = cfg_image_dir($cfg);
3457
3458   require DevHelp::FileUpload;
3459   my $msg;
3460   my ($filename, $fh) =
3461     DevHelp::FileUpload->make_img_filename($imagedir, $basename, \$msg);
3462   unless ($filename) {
3463     $errors->{image} = $msg;
3464     return;
3465   }
3466
3467   my $buffer;
3468
3469   binmode $fh;
3470
3471   no strict 'refs';
3472
3473   # read the image in from the browser and output it to our output filehandle
3474   print $fh $buffer while read $image, $buffer, 1024;
3475
3476   # close and flush
3477   close $fh
3478     or die "Could not close image file $filename: $!";
3479
3480   my $display_order = time;
3481   if ($display_order <= $last_display_order) {
3482     $display_order = $last_display_order + 1;
3483   }
3484   $last_display_order = $display_order;
3485
3486   my $alt = $opts{alt};
3487   defined $alt or $alt = '';
3488   my $url = $opts{url};
3489   defined $url or $url = '';
3490   my %image =
3491     (
3492      articleId => $article->{id},
3493      image => $filename,
3494      alt=>$alt,
3495      width=>$width,
3496      height => $height,
3497      url => $url,
3498      displayOrder => $display_order,
3499      name => $imageref,
3500      storage => 'local',
3501      src => cfg_image_uri() . '/' . $filename,
3502      ftype => $self->_image_ftype($type),
3503     );
3504   require BSE::TB::Images;
3505   my @cols = BSE::TB::Image->columns;
3506   shift @cols;
3507   my $imageobj = BSE::TB::Images->add(@image{@cols});
3508
3509   my $storage = $opts{storage};
3510   defined $storage or $storage = 'local';
3511   my $image_manager = $self->_image_manager($cfg);
3512   local $SIG{__DIE__};
3513   eval {
3514     my $src;
3515     $storage = $image_manager->select_store($filename, $storage, $imageobj);
3516     $src = $image_manager->store($filename, $storage, $imageobj);
3517
3518     if ($src) {
3519       $imageobj->{src} = $src;
3520       $imageobj->{storage} = $storage;
3521       $imageobj->save;
3522     }
3523   };
3524   if ($@) {
3525     $errors->{flash} = $@;
3526   }
3527
3528   return $imageobj;
3529 }
3530
3531 sub _image_data {
3532   my ($self, $cfg, $image) = @_;
3533
3534   my $data = $image->data_only;
3535   $data->{src} = $image->image_url($cfg);
3536
3537   return $data;
3538 }
3539
3540 sub add_image {
3541   my ($self, $req, $article, $articles) = @_;
3542
3543   $req->check_csrf("admin_add_image")
3544     or return $self->csrf_error($req, $article, "admin_add_image", "Add Image");
3545   $req->user_can(edit_images_add => $article)
3546     or return $self->_service_error($req, $article, $articles,
3547                                     "You don't have access to add new images to this article");
3548
3549   my $cgi = $req->cgi;
3550
3551   my %errors;
3552
3553   my $save_tags = $cgi->param("_save_tags");
3554   my @tags;
3555   if ($save_tags) {
3556     @tags = $cgi->param("tags");
3557     $self->_validate_tags(\@tags, \%errors);
3558   }
3559
3560   my $imageobj =
3561     $self->do_add_image
3562       (
3563        $req->cfg,
3564        $article,
3565        scalar($cgi->upload('image')),
3566        name => scalar($cgi->param('name')),
3567        alt => scalar($cgi->param('altIn')),
3568        url => scalar($cgi->param('url')),
3569        storage => scalar($cgi->param('storage')),
3570        errors => \%errors,
3571        filename => scalar($cgi->param("image")),
3572       );
3573
3574   $imageobj
3575     or return $self->_service_error($req, $article, $articles, undef, \%errors);
3576
3577   if ($save_tags) {
3578     my $error;
3579     $imageobj->set_tags([ grep /\S/, @tags ], \$error);
3580   }
3581
3582   # typically a soft failure from the storage
3583   $errors{flash}
3584     and $req->flash($errors{flash});
3585
3586   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3587
3588   if ($cgi->param('_service')) {
3589     return $self->_service_success
3590       (
3591        {
3592         image => $imageobj->{id},
3593        },
3594       );
3595   }
3596   elsif ($cgi->param("_") || $req->is_ajax) {
3597     my $resp = $req->json_content
3598       (
3599        success => 1,
3600        image => $self->_image_data($req->cfg, $imageobj),
3601       );
3602
3603     # the browser handles this directly, tell it that it's text
3604     $resp->{type} = "text/plain";
3605
3606     return $resp;
3607   }
3608   else {
3609     return $self->refresh($article, $cgi, undef, 'New image added');
3610   }
3611 }
3612
3613 sub _image_manager {
3614   my ($self) = @_;
3615
3616   require BSE::TB::Images;
3617   return BSE::TB::Images->storage_manager;
3618 }
3619
3620 # remove an image
3621 sub remove_img {
3622   my ($self, $req, $article, $articles, $imageid) = @_;
3623
3624   $req->check_csrf("admin_remove_image")
3625     or return $self->csrf_error($req, $article, "admin_remove_image", "Remove Image");
3626
3627   $req->user_can(edit_images_delete => $article)
3628     or return $self->_service_error($req, $article, $articles,
3629                                  "You don't have access to delete images from this article", {}, "ACCESS");
3630
3631   $imageid or die;
3632
3633   my @images = $self->get_images($article);
3634   my ($image) = grep $_->{id} == $imageid, @images;
3635   unless ($image) {
3636     if ($req->want_json_response) {
3637       return $self->_service_error($req, $article, $articles, "No such image", {}, "NOTFOUND");
3638     }
3639     else {
3640       return $self->show_images($req, $article, $articles, "No such image");
3641     }
3642   }
3643
3644   if ($image->{storage} ne 'local') {
3645     my $mgr = $self->_image_manager($req->cfg);
3646     $mgr->unstore($image->{image}, $image->{storage});
3647   }
3648
3649   my $imagedir = cfg_image_dir($req->cfg);
3650   $image->remove;
3651
3652   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3653
3654   if ($req->want_json_response) {
3655     return $req->json_content
3656       (
3657        success => 1,
3658       );
3659   }
3660
3661   return $self->refresh($article, $req->cgi, undef, 'Image removed');
3662 }
3663
3664 sub move_img_up {
3665   my ($self, $req, $article, $articles) = @_;
3666
3667   $req->check_csrf("admin_move_image")
3668     or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
3669   $req->user_can(edit_images_reorder => $article)
3670     or return $self->edit_form($req, $article, $articles,
3671                                  "You don't have access to reorder images in this article");
3672
3673   my $imageid = $req->cgi->param('imageid');
3674   my @images = $self->get_images($article);
3675   my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
3676     or return $self->edit_form($req, $article, $articles, "No such image");
3677   $imgindex > 0
3678     or return $self->edit_form($req, $article, $articles, "Image is already at the top");
3679   my ($to, $from) = @images[$imgindex-1, $imgindex];
3680   ($to->{displayOrder}, $from->{displayOrder}) =
3681     ($from->{displayOrder}, $to->{displayOrder});
3682   $to->save;
3683   $from->save;
3684
3685   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3686
3687   return $self->refresh($article, $req->cgi, undef, 'Image moved');
3688 }
3689
3690 sub move_img_down {
3691   my ($self, $req, $article, $articles) = @_;
3692
3693   $req->check_csrf("admin_move_image")
3694     or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
3695   $req->user_can(edit_images_reorder => $article)
3696     or return $self->edit_form($req, $article, $articles,
3697                                  "You don't have access to reorder images in this article");
3698
3699   my $imageid = $req->cgi->param('imageid');
3700   my @images = $self->get_images($article);
3701   my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
3702     or return $self->edit_form($req, $article, $articles, "No such image");
3703   $imgindex < $#images
3704     or return $self->edit_form($req, $article, $articles, "Image is already at the end");
3705   my ($to, $from) = @images[$imgindex+1, $imgindex];
3706   ($to->{displayOrder}, $from->{displayOrder}) =
3707     ($from->{displayOrder}, $to->{displayOrder});
3708   $to->save;
3709   $from->save;
3710
3711   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3712
3713   return $self->refresh($article, $req->cgi, undef, 'Image moved');
3714 }
3715
3716 sub req_thumb {
3717   my ($self, $req, $article) = @_;
3718
3719   my $cgi = $req->cgi;
3720   my $cfg = $req->cfg;
3721   my $im_id = $cgi->param('im');
3722   my $image;
3723   if (defined $im_id && $im_id =~ /^\d+$/) {
3724     ($image) = grep $_->{id} == $im_id, $self->get_images($article);
3725   }
3726   my $thumb_obj = $self->_get_thumbs_class();
3727   my ($data, $type);
3728   if ($image && $thumb_obj) {
3729     my $geometry_id = $cgi->param('g');
3730     defined $geometry_id or $geometry_id = 'editor';
3731     my $geometry = $cfg->entry('thumb geometries', $geometry_id, 'scale(200x200)');
3732     my $imagedir = cfg_image_dir();
3733
3734     my $error;
3735     ($data, $type) = $thumb_obj->thumb_data
3736       (
3737        filename => "$imagedir/$image->{image}",
3738        geometry => $geometry,
3739        error => \$error
3740       )
3741         or return
3742           {
3743            type => 'text/plain',
3744            content => 'Error: '.$error
3745           };
3746   }
3747
3748   if ($type && $data) {
3749
3750     return
3751       {
3752        type => $type,
3753        content => $data,
3754        headers => [
3755                    "Content-Length: ".length($data),
3756                    "Cache-Control: max-age=3600",
3757                   ],
3758       };
3759   }
3760   else {
3761     # grab the nothumb image
3762     my $uri = $cfg->entry('editor', 'default_thumbnail', cfg_dist_image_uri() . '/admin/nothumb.png');
3763     my $filebase = $cfg->content_base_path;
3764     if (open IMG, "<$filebase/$uri") {
3765       binmode IMG;
3766       my $data = do { local $/; <IMG> };
3767       close IMG;
3768       my $type = $uri =~ /\.(\w+)$/ ? $1 : 'png';
3769       return
3770         {
3771          type => "image/$type",
3772          content => $data,
3773          headers => [ "Content-Length: ".length($data) ],
3774         };
3775     }
3776     else {
3777       return
3778         {
3779          type=>"text/html",
3780          content => "<html><body>Cannot make thumb or default image</body></html>",
3781         };
3782     }
3783   }
3784 }
3785
3786 =item edit_image
3787
3788 Display a form to allow editing an image.
3789
3790 Tags:
3791
3792 =over
3793
3794 =item *
3795
3796 eimage - the image being edited
3797
3798 =item *
3799
3800 normal article edit tags.
3801
3802 =back
3803
3804 Variables:
3805
3806 eimage - the image being edited.
3807
3808 =cut
3809
3810 sub req_edit_image {
3811   my ($self, $req, $article, $articles, $errors) = @_;
3812
3813   my $cgi = $req->cgi;
3814
3815   my $id = $cgi->param('image_id');
3816
3817   my ($image) = grep $_->{id} == $id, $self->get_images($article)
3818     or return $self->edit_form($req, $article, $articles,
3819                                "No such image");
3820   $req->user_can(edit_images_save => $article)
3821     or return $self->edit_form($req, $article, $articles,
3822                                "You don't have access to save image information for this article");
3823
3824   $req->set_variable(eimage => $image);
3825
3826   my %acts;
3827   %acts =
3828     (
3829      $self->low_edit_tags(\%acts, $req, $article, $articles, undef,
3830                           $errors),
3831      eimage => [ \&tag_hash, $image ],
3832      error_img => [ \&tag_error_img, $req->cfg, $errors ],
3833     );
3834
3835   return $req->response('admin/image_edit', \%acts);
3836 }
3837
3838 =item a_save_image
3839
3840 Save changes to an image.
3841
3842 Parameters:
3843
3844 =over
3845
3846 =item *
3847
3848 id - article id
3849
3850 =item *
3851
3852 image_id - image id
3853
3854 =item *
3855
3856 alt, url, name - text fields to update
3857
3858 =item *
3859
3860 image - replacement image data (if any)
3861
3862 =back
3863
3864 =cut
3865
3866 sub req_save_image {
3867   my ($self, $req, $article, $articles) = @_;
3868
3869   $req->check_csrf("admin_save_image")
3870     or return $self->csrf_error($req, $article, "admin_save_image", "Save Image");
3871   my $cgi = $req->cgi;
3872
3873   my $id = $cgi->param('image_id');
3874
3875   my @images = $self->get_images($article);
3876   my ($image) = grep $_->{id} == $id, @images
3877     or return $self->_service_error($req, $article, $articles, "No such image",
3878                                     {}, "NOTFOUND");
3879   $req->user_can(edit_images_save => $article)
3880     or return $self->_service_error($req, $article, $articles,
3881                                     "You don't have access to save image information for this article", {}, "ACCESS");
3882
3883   my $image_dir = cfg_image_dir($req->cfg);
3884
3885   my $old_storage = $image->{storage};
3886
3887   my %errors;
3888   my $delete_file;
3889   my $alt = $cgi->param('alt');
3890   defined $alt and $image->{alt} = $alt;
3891   my $url = $cgi->param('url');
3892   defined $url and $image->{url} = $url;
3893   my @other_images = grep $_->{id} != $id, @images;
3894   my $name = $cgi->param('name');
3895   if (defined $name) {
3896     if (length $name) {
3897       if ($name !~ /^[a-z_]\w*$/i) {
3898         $errors{name} = 'Image name must be empty or alphanumeric and unique to the article';
3899       }
3900       elsif (grep $name eq $_->{name}, @other_images) {
3901         $errors{name} = 'Image name must be unique to the article';
3902       }
3903       else {
3904         $image->{name} = $name;
3905       }
3906     }
3907     else {
3908       $image->{name} = '';
3909     }
3910   }
3911   my $filename = $cgi->param('image');
3912   if (defined $filename && length $filename) {
3913     my $in_fh = $cgi->upload('image');
3914     if ($in_fh) {
3915       my $basename;
3916       my $image_error;
3917       my ($width, $height, $type) = $self->_validate_image
3918         ($filename, $in_fh, \$basename, \$image_error);
3919       if ($type) {
3920         require DevHelp::FileUpload;
3921         my $msg;
3922         my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3923           ($image_dir, $basename, \$msg);
3924         if ($image_name) {
3925           {
3926             local $/ = \8192;
3927             my $data;
3928             while ($data = <$in_fh>) {
3929               print $out_fh $data;
3930             }
3931             close $out_fh;
3932           }
3933
3934           my $full_filename = "$image_dir/$image_name";
3935           $delete_file = $image->{image};
3936           $image->{image} = $image_name;
3937           $image->{width} = $width;
3938           $image->{height} = $height;
3939           $image->{storage} = 'local'; # not on the remote store yet
3940           $image->{src} = cfg_image_uri() . '/' . $image_name;
3941           $image->{ftype} = $self->_image_ftype($type);
3942         }
3943         else {
3944           $errors{image} = $msg;
3945         }
3946       }
3947       else {
3948         $errors{image} = $image_error;
3949       }
3950     }
3951     else {
3952       $errors{image} = "No image file received";
3953     }
3954   }
3955   my $save_tags = $cgi->param("_save_tags");
3956   my @tags;
3957   if ($save_tags) {
3958     @tags = $cgi->param("tags");
3959     $self->_validate_tags(\@tags, \%errors);
3960   }
3961   if (keys %errors) {
3962     if ($req->want_json_response) {
3963       return $self->_service_error($req, $article, $articles, undef,
3964                                    \%errors, "FIELD");
3965     }
3966     else {
3967       return $self->req_edit_image($req, $article, $articles, \%errors);
3968     }
3969   }
3970
3971   my $new_storage = $cgi->param('storage');
3972   defined $new_storage or $new_storage = $image->{storage};
3973   $image->save;
3974   if ($save_tags) {
3975     my $error;
3976     $image->set_tags([ grep /\S/, @tags ], \$error);
3977   }
3978   my $mgr = $self->_image_manager($req->cfg);
3979   if ($delete_file) {
3980     if ($old_storage ne 'local') {
3981       $mgr->unstore($delete_file, $old_storage);
3982     }
3983     unlink "$image_dir/$delete_file";
3984   }
3985   $req->flash("Image saved");
3986   eval {
3987     $new_storage =
3988       $mgr->select_store($image->{image}, $new_storage);
3989     if ($image->{storage} ne $new_storage) {
3990       # handles both new images (which sets storage to local) and changing
3991       # the storage for old images
3992       my $old_storage = $image->{storage};
3993       my $src = $mgr->store($image->{image}, $new_storage, $image);
3994       $image->{src} = $src;
3995       $image->{storage} = $new_storage;
3996       $image->save;
3997     }
3998   };
3999   $@ and $req->flash("There was a problem adding it to the new storage: $@");
4000   if ($image->{storage} ne $old_storage && $old_storage ne 'local') {
4001     eval {
4002       $mgr->unstore($image->{image}, $old_storage);
4003     };
4004     $@ and $req->flash("There was a problem removing if from the old storage: $@");
4005   }
4006
4007   if ($req->want_json_response) {
4008     return $req->json_content
4009       (
4010        success => 1,
4011        image => $self->_image_data($req->cfg, $image),
4012       );
4013   }
4014
4015   return $self->refresh($article, $cgi);
4016 }
4017
4018 =item a_order_images
4019
4020 Change the order of images for an article (or global images).
4021
4022 Ajax only.
4023
4024 =over
4025
4026 =item *
4027
4028 id - id of the article to change the image order for (-1 for global
4029 images)
4030
4031 =item *
4032
4033 order - comma-separated list of image ids in the new order.
4034
4035 =back
4036
4037 =cut
4038
4039 sub req_order_images {
4040   my ($self, $req, $article, $articles) = @_;
4041
4042   $req->is_ajax
4043     or return $self->_service_error($req, $article, $articles, "The function only permitted from Ajax", {}, "AJAXONLY");
4044
4045   my $order = $req->cgi->param("order");
4046   defined $order
4047     or return $self->_service_error($req, $article, $articles, "order not supplied", {}, "NOORDER");
4048   $order =~ /^\d+(,\d+)*$/
4049     or return $self->_service_error($req, $article, $articles, "order not supplied", {}, "BADORDER");
4050
4051   my @order = split /,/, $order;
4052
4053   my @images = $article->set_image_order(\@order);
4054
4055   return $req->json_content
4056     (
4057      success => 1,
4058      images =>
4059      [
4060       map $self->_image_data($req->cfg, $_), @images
4061      ],
4062     );
4063 }
4064
4065 sub get_article {
4066   my ($self, $articles, $article) = @_;
4067
4068   return $article;
4069 }
4070
4071 sub table_object {
4072   my ($self, $articles) = @_;
4073
4074   $articles;
4075 }
4076
4077 sub _refresh_filelist {
4078   my ($self, $req, $article, $msg) = @_;
4079
4080   return $self->refresh($article, $req->cgi, undef, $msg);
4081 }
4082
4083 sub filelist {
4084   my ($self, $req, $article, $articles, $msg, $errors) = @_;
4085
4086   my %acts;
4087   %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
4088   my $template = 'admin/filelist';
4089
4090   return BSE::Template->get_response($template, $req->cfg, \%acts);
4091 }
4092
4093 my %file_fields =
4094   (
4095    file =>
4096    {
4097     maxlength => MAX_FILE_DISPLAYNAME_LENGTH,
4098     description => 'Filename'
4099    },
4100    description =>
4101    {
4102     rules => 'dh_one_line',
4103     maxlength => 255,
4104     description => 'Description',
4105    },
4106    name =>
4107    {
4108     description => 'Identifier',
4109     maxlength => 80,
4110    },
4111    category =>
4112    {
4113     description => "Category",
4114     maxlength => 20,
4115    },
4116   );
4117
4118 sub fileadd {
4119   my ($self, $req, $article, $articles) = @_;
4120
4121   $req->check_csrf("admin_add_file")
4122     or return $self->csrf_error($req, $article, "admin_add_file", "Add File");
4123   $req->user_can(edit_files_add => $article)
4124     or return $self->_service_error($req, $article, $articles,
4125                               "You don't have access to add files to this article");
4126
4127   my %file;
4128   my $cgi = $req->cgi;
4129   require BSE::TB::ArticleFiles;
4130   my @cols = BSE::TB::ArticleFile->columns;
4131   shift @cols;
4132   for my $col (@cols) {
4133     if (defined $cgi->param($col)) {
4134       $file{$col} = $cgi->param($col);
4135     }
4136   }
4137
4138   my %errors;
4139
4140   $req->validate(errors => \%errors,
4141                  fields => \%file_fields,
4142                  section => $article->{id} == -1 ? 'Global File Validation' : 'Article File Validation');
4143
4144   # build a filename
4145   my $file = $cgi->upload('file');
4146   my $filename = $cgi->param("file");
4147   unless ($file) {
4148     $errors{file} = 'Please enter a filename';
4149   }
4150   if ($file && -z $file) {
4151     $errors{file} = 'File is empty';
4152   }
4153
4154   $file{forSale}        = 0 + exists $file{forSale};
4155   $file{articleId}      = $article->{id};
4156   $file{download}       = 0 + exists $file{download};
4157   $file{requireUser}    = 0 + exists $file{requireUser};
4158   $file{hide_from_list} = 0 + exists $file{hide_from_list};
4159   $file{category}       ||= '';
4160
4161   defined $file{name} or $file{name} = '';
4162   if (!$errors{name} && length $file{name} && $file{name} !~/^\w+$/) {
4163     $errors{name} = "Identifier must be a single word";
4164   }
4165   if (!$errors{name} && length $file{name}) {
4166     my @files = $self->get_files($article);
4167     if (grep lc $_->{name} eq lc $file{name}, @files) {
4168       $errors{name} = "Duplicate file identifier $file{name}";
4169     }
4170   }
4171
4172   keys %errors
4173     and return $self->_service_error($req, $article, $articles, undef, \%errors);
4174
4175   my $basename = '';
4176   my $workfile = $filename;
4177   $workfile =~ s![^\w.:/\\-]+!_!g;
4178   $workfile =~ tr/_/_/s;
4179   $workfile =~ /([ \w.-]+)$/ and $basename = $1;
4180   $basename =~ tr/ /_/;
4181   $file{displayName} = $basename;
4182   $file{file} = $file;
4183
4184   local $SIG{__DIE__};
4185   my $fileobj =
4186     eval {
4187       $article->add_file($self->cfg, %file);
4188     };
4189
4190   $fileobj
4191     or return $self->_service_error($req, $article, $articles, $@);
4192
4193   unless ($req->is_ajax) {
4194     $req->flash("New file added");
4195   }
4196
4197   my $json =
4198     {
4199      success => 1,
4200      file => $fileobj->data_only,
4201      warnings => [],
4202     };
4203   my $storage = $cgi->param("storage") || "";
4204   eval {
4205     my $msg;
4206
4207     $article->apply_storage($self->cfg, $fileobj, $storage, \$msg);
4208
4209     if ($msg) {
4210       if ($req->is_ajax) {
4211         push @{$json->{warnings}}, $msg;
4212       }
4213       else {
4214         $req->flash_error($msg);
4215       }
4216     }
4217   };
4218   if ($@) {
4219     if ($req->is_ajax) {
4220       push @{$json->{warnings}}, $@;
4221     }
4222     else {
4223       $req->flash_error($@);
4224     }
4225   }
4226
4227   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4228
4229   if ($req->is_ajax) {
4230     return $req->json_content($json);
4231   }
4232   else {
4233     $self->_refresh_filelist($req, $article);
4234   }
4235 }
4236
4237 sub fileswap {
4238   my ($self, $req, $article, $articles) = @_;
4239
4240   $req->check_csrf("admin_move_file")
4241     or return $self->csrf_error($req, $article, "admin_move_file", "Move File");
4242
4243   $req->user_can('edit_files_reorder', $article)
4244     or return $self->edit_form($req, $article, $articles,
4245                            "You don't have access to reorder files in this article");
4246
4247   my $cgi = $req->cgi;
4248   my $id1 = $cgi->param('file1');
4249   my $id2 = $cgi->param('file2');
4250
4251   if ($id1 && $id2) {
4252     my @files = $self->get_files($article);
4253
4254     my ($file1) = grep $_->{id} == $id1, @files;
4255     my ($file2) = grep $_->{id} == $id2, @files;
4256
4257     if ($file1 && $file2) {
4258       ($file1->{displayOrder}, $file2->{displayOrder})
4259         = ($file2->{displayOrder}, $file1->{displayOrder});
4260       $file1->save;
4261       $file2->save;
4262     }
4263   }
4264
4265   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4266
4267   $self->refresh($article, $req->cgi, undef, 'File moved');
4268 }
4269
4270 sub filedel {
4271   my ($self, $req, $article, $articles) = @_;
4272
4273   $req->check_csrf("admin_remove_file")
4274     or return $self->csrf_error($req, $article, "admin_remove_file", "Delete File");
4275   $req->user_can('edit_files_delete', $article)
4276     or return $self->edit_form($req, $article, $articles,
4277                                "You don't have access to delete files from this article");
4278
4279   my $cgi = $req->cgi;
4280   my $fileid = $cgi->param('file');
4281   if ($fileid) {
4282     my @files = $self->get_files($article);
4283
4284     my ($file) = grep $_->{id} == $fileid, @files;
4285
4286     if ($file) {
4287       if ($file->{storage} ne 'local') {
4288         my $mgr = $self->_file_manager($self->cfg);
4289         $mgr->unstore($file->{filename}, $file->{storage});
4290       }
4291
4292       $file->remove($req->cfg);
4293     }
4294   }
4295
4296   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4297
4298   $self->_refresh_filelist($req, $article, 'File deleted');
4299 }
4300
4301 sub filesave {
4302   my ($self, $req, $article, $articles) = @_;
4303
4304   $req->check_csrf("admin_save_files")
4305     or return $self->csrf_error($req, $article, "admin_save_files", "Save Files");
4306
4307   $req->user_can('edit_files_save', $article)
4308     or return $self->edit_form($req, $article, $articles,
4309                            "You don't have access to save file information for this article");
4310   my @files = $self->get_files($article);
4311
4312   my $download_path = BSE::TB::ArticleFiles->download_path($self->{cfg});
4313
4314   my $cgi = $req->cgi;
4315   my %names;
4316   my %errors;
4317   my @old_files;
4318   my @new_files;
4319   my %store_anyway;
4320   my $change_count = 0;
4321   my @content_changed;
4322   for my $file (@files) {
4323     my $id = $file->{id};
4324     my $orig = $file->data_only;
4325     my $desc = $cgi->param("description_$id");
4326     defined $desc and $file->{description} = $desc;
4327     my $type = $cgi->param("contentType_$id");
4328     if (defined $type and $type ne $file->{contentType}) {
4329       ++$store_anyway{$id};
4330       $file->{contentType} = $type;
4331     }
4332     my $notes = $cgi->param("notes_$id");
4333     defined $notes and $file->{notes} = $notes;
4334     my $category = $cgi->param("category_$id");
4335     defined $category and $file->{category} = $category;
4336     my $name = $cgi->param("name_$id");
4337     if (defined $name) {
4338       $file->{name} = $name;
4339       if (length $name) {
4340         if ($name =~ /^\w+$/) {
4341           push @{$names{$name}}, $id;
4342         }
4343         else {
4344           $errors{"name_$id"} = "Invalid file identifier $name";
4345         }
4346       }
4347     }
4348     else {
4349       push @{$names{$file->{name}}}, $id
4350         if length $file->{name};
4351     }
4352     if ($cgi->param('save_file_flags')) {
4353       my $download = 0 + defined $cgi->param("download_$id");
4354       if ($download != $file->{download}) {
4355         ++$store_anyway{$file->{id}};
4356         $file->{download}             = $download;
4357       }
4358       $file->{forSale}        = 0 + defined $cgi->param("forSale_$id");
4359       $file->{requireUser}    = 0 + defined $cgi->param("requireUser_$id");
4360       $file->{hide_from_list} = 0 + defined $cgi->param("hide_from_list_$id");
4361     }
4362
4363     my $filex = $cgi->param("file_$id");
4364     my $in_fh = $cgi->upload("file_$id");
4365     if (defined $filex && length $filex) {
4366       if (length $filex <= MAX_FILE_DISPLAYNAME_LENGTH) {
4367         if ($in_fh) {
4368           if (-s $in_fh) {
4369             require DevHelp::FileUpload;
4370             my $msg;
4371             my ($file_name, $out_fh) = DevHelp::FileUpload->make_img_filename
4372               ($download_path, $filex . '', \$msg);
4373             if ($file_name) {
4374               {
4375                 local $/ = \8192;
4376                 my $data;
4377                 while ($data = <$in_fh>) {
4378                   print $out_fh $data;
4379                 }
4380                 close $out_fh;
4381               }
4382               my $display_name = $filex;
4383               $display_name =~ s!.*[\\:/]!!;
4384               $display_name =~ s/[^\w._-]+/_/g;
4385               my $full_name = "$download_path/$file_name";
4386               push @old_files, [ $file->{filename}, $file->{storage} ];
4387               push @new_files, $file_name;
4388
4389               $file->{filename} = $file_name;
4390               $file->{storage} = 'local';
4391               $file->{sizeInBytes} = -s $full_name;
4392               $file->{whenUploaded} = now_sqldatetime();
4393               $file->{displayName} = $display_name;
4394               push @content_changed, $file;
4395             }
4396             else {
4397               $errors{"file_$id"} = $msg;
4398             }
4399           }
4400           else {
4401             $errors{"file_$id"} = "File is empty";
4402           }
4403         }
4404         else {
4405           $errors{"file_$id"} = "No file data received";
4406         }
4407       }
4408       else {
4409         $errors{"file_$id"} = "Filename too long";
4410       }
4411     }
4412
4413     my $new = $file->data_only;
4414   COLUMN:
4415     for my $col ($file->columns) {
4416       if ($new->{$col} ne $orig->{$col}) {
4417         ++$change_count;
4418         last COLUMN;
4419       }
4420     }
4421   }
4422   for my $name (keys %names) {
4423     if (@{$names{$name}} > 1) {
4424       for my $id (@{$names{$name}}) {
4425         $errors{"name_$id"} = 'File identifier must be unique to the article';
4426       }
4427     }
4428   }
4429   if (keys %errors) {
4430     # remove the uploaded replacements
4431     unlink map "$download_path/$_", @new_files;
4432
4433     return $self->edit_form($req, $article, $articles, undef, \%errors);
4434   }
4435   if ($change_count) {
4436     $req->flash("msg:bse/admin/edit/file/save/success_count", [ $change_count ]);
4437   }
4438   else {
4439     $req->flash("msg:bse/admin/edit/file/save/success_none");
4440   }
4441   my $mgr = $self->_file_manager($self->cfg);
4442   for my $file (@files) {
4443     $file->save;
4444
4445     my $storage = $cgi->param("storage_$file->{id}");
4446     defined $storage or $storage = 'local';
4447     my $msg;
4448     $storage = $article->select_filestore($mgr, $file, $storage, \$msg);
4449     $msg and $req->flash($msg);
4450     if ($storage ne $file->{storage} || $store_anyway{$file->{id}}) {
4451       my $old_storage = $file->{storage};
4452       eval {
4453         $file->{src} = $mgr->store($file->{filename}, $storage, $file);
4454         $file->{storage} = $storage;
4455         $file->save;
4456
4457         if ($old_storage ne $storage) {
4458           $mgr->unstore($file->{filename}, $old_storage);
4459         }
4460       };
4461       $@
4462         and $req->flash("Could not move $file->{displayName} to $storage: $@");
4463     }
4464   }
4465
4466   # remove the replaced files
4467   for my $file (@old_files) {
4468     my ($filename, $storage) = @$file;
4469
4470     eval {
4471       $mgr->unstore($filename, $storage);
4472     };
4473     $@
4474       and $req->flash("Error removing $filename from $storage: $@");
4475
4476     unlink "$download_path/$filename";
4477   }
4478
4479   # update file type metadatas
4480   for my $file (@content_changed) {
4481     $file->set_handler($self->{cfg});
4482     $file->save;
4483   }
4484
4485   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4486
4487   $self->_refresh_filelist($req, $article);
4488 }
4489
4490 sub req_filemeta {
4491   my ($self, $req, $article, $articles, $errors) = @_;
4492
4493   my $cgi = $req->cgi;
4494
4495   my $id = $cgi->param('file_id');
4496
4497   my ($file) = grep $_->{id} == $id, $self->get_files($article)
4498     or return $self->edit_form($req, $article, $articles,
4499                                "No such file");
4500   $req->user_can(edit_files_save => $article)
4501     or return $self->edit_form($req, $article, $articles,
4502                                "You don't have access to save file information for this article");
4503
4504   my $name = $cgi->param('name');
4505   $name && $name =~ /^\w+$/
4506     or return $self->edit_form($req, $article, $articles,
4507                                "Missing or invalid metadata name");
4508
4509   my $meta = $file->meta_by_name($name)
4510     or return $self->edit_form($req, $article, $articles,
4511                                "Metadata $name not defined for this file");
4512
4513   return
4514     {
4515      type => $meta->content_type,
4516      content => $meta->value,
4517     };
4518 }
4519
4520 sub tag_old_checked {
4521   my ($errors, $cgi, $file, $key) = @_;
4522
4523   return $errors ? $cgi->param($key) : $file->{$key};
4524 }
4525
4526 sub tag_filemeta_value {
4527   my ($file, $args, $acts, $funcname, $templater) = @_;
4528
4529   my ($name) = DevHelp::Tags->get_parms($args, $acts, $templater)
4530     or return "* no meta name supplied *";
4531
4532   my $meta = $file->meta_by_name($name)
4533     or return "";
4534
4535   $meta->content_type eq "text/plain"
4536     or return "* $name has type " . $meta->content_type . " and cannot be displayed inline *";
4537
4538   return escape_html($meta->value);
4539 }
4540
4541 sub tag_ifFilemeta_set {
4542   my ($file, $args, $acts, $funcname, $templater) = @_;
4543
4544   my ($name) = DevHelp::Tags->get_parms($args, $acts, $templater)
4545     or return "* no meta name supplied *";
4546
4547   my $meta = $file->meta_by_name($name)
4548     or return 0;
4549
4550   return 1;
4551 }
4552
4553 sub tag_filemeta_source {
4554   my ($file, $args, $acts, $funcname, $templater) = @_;
4555
4556   my ($name) = DevHelp::Tags->get_parms($args, $acts, $templater)
4557     or return "* no meta name supplied *";
4558
4559   return "$ENV{SCRIPT_NAME}?a_filemeta=1&amp;id=$file->{articleId}&amp;file_id=$file->{id}&amp;name=$name";
4560 }
4561
4562 sub tag_filemeta_select {
4563   my ($cgi, $allmeta, $rcurr_meta, $file, $args, $acts, $funcname, $templater) = @_;
4564
4565   my $meta;
4566   if ($args =~ /\S/) {
4567     my ($name) = DevHelp::Tags->get_parms($args, $acts, $templater)
4568       or return "* cannot parse *";
4569     ($meta) = grep $_->name eq $name, @$allmeta
4570       or return "* cannot find meta field *";
4571   }
4572   elsif ($$rcurr_meta) {
4573     $meta = $$rcurr_meta;
4574   }
4575   else {
4576     return "* use in filemeta iterator or supply a name *";
4577   }
4578
4579   $meta->type eq "enum"
4580     or return "* can only use filemeta_select on enum metafields&