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 *";
4581
4582   my %labels;
4583   my @values = $meta->values;
4584   @labels{@values} = $meta->labels;
4585
4586   my $field_name = "meta_" . $meta->name;
4587   my ($def) = $cgi->param($field_name);
4588   unless (defined $def) {
4589     my $value = $file->meta_by_name($meta->name);
4590     if ($value && $value->is_text) {
4591       $def = $value->value;
4592     }
4593   }
4594   defined $def or $def = $values[0];
4595
4596   return popup_menu
4597     (
4598      -name => $field_name,
4599      -values => \@values,
4600      -labels => \%labels,
4601      -default => $def,
4602     );
4603 }
4604
4605 sub tag_filemeta_select_label {
4606   my ($allmeta, $rcurr_meta, $file, $args, $acts, $funcname, $templater) = @_;
4607
4608   my $meta;
4609   if ($args =~ /\S/) {
4610     my ($name) = DevHelp::Tags->get_parms($args, $acts, $templater)
4611       or return "* cannot parse *";
4612     ($meta) = grep $_->name eq $name, @$allmeta
4613       or return "* cannot find meta field *";
4614   }
4615   elsif ($$rcurr_meta) {
4616     $meta = $$rcurr_meta;
4617   }
4618   else {
4619     return "* use in filemeta iterator or supply a name *";
4620   }
4621
4622   $meta->type eq "enum"
4623     or return "* can only use filemeta_select_label on enum metafields *";
4624
4625   my %labels;
4626   my @values = $meta->values;
4627   @labels{@values} = $meta->labels;
4628
4629   my $field_name = "meta_" . $meta->name;
4630   my $value = $file->meta_by_name($meta->name);
4631   if ($value) {
4632     if ($value->is_text) {
4633       if (exists $labels{$value->value}) {
4634         return escape_html($labels{$value->value});
4635       }
4636       else {
4637         return escape_html($value->value);
4638       }
4639     }
4640     else {
4641       return "* cannot display type " . $value->content_type . " inline *";
4642     }
4643   }
4644   else {
4645     return "* " . $meta->name . " not set *";
4646   }
4647 }
4648
4649 sub req_edit_file {
4650   my ($self, $req, $article, $articles, $errors) = @_;
4651
4652   my $cgi = $req->cgi;
4653
4654   my $id = $cgi->param('file_id');
4655
4656   my ($file) = grep $_->{id} == $id, $self->get_files($article)
4657     or return $self->edit_form($req, $article, $articles,
4658                                "No such file");
4659   $req->user_can(edit_files_save => $article)
4660     or return $self->edit_form($req, $article, $articles,
4661                                "You don't have access to save file information for this article");
4662
4663   my @metafields = $file->metafields($self->cfg);
4664
4665   $req->set_variable(file => $file);
4666   $req->set_variable(fields => { BSE::TB::ArticleFile->fields });
4667
4668   my $it = BSE::Util::Iterate->new;
4669   my $current_meta;
4670   my %acts;
4671   %acts =
4672     (
4673      $self->low_edit_tags(\%acts, $req, $article, $articles, undef,
4674                           $errors),
4675      efile => [ \&tag_object, $file ],
4676      error_img => [ \&tag_error_img, $req->cfg, $errors ],
4677      ifOldChecked =>
4678      [ \&tag_old_checked, $errors, $cgi, $file ],
4679      $it->make
4680      (
4681       plural => "filemetas",
4682       single => "filemeta",
4683       data => \@metafields,
4684       store => \$current_meta,
4685      ),
4686      filemeta_value =>
4687      [ \&tag_filemeta_value, $file ],
4688      ifFilemeta_set =>
4689      [ \&tag_ifFilemeta_set, $file ],
4690      filemeta_source =>
4691      [ \&tag_filemeta_source, $file ],
4692      filemeta_select =>
4693      [ \&tag_filemeta_select, $cgi, \@metafields, \$current_meta, $file ],
4694      filemeta_select_label =>
4695      [ \&tag_filemeta_select_label, \@metafields, \$current_meta, $file ],
4696     );
4697
4698   return $req->response('admin/file_edit', \%acts);
4699 }
4700
4701 sub req_save_file {
4702   my ($self, $req, $article, $articles) = @_;
4703
4704   $req->check_csrf("admin_save_file")
4705     or return $self->csrf_error($req, $article, "admin_save_file", "Save File");
4706
4707   my $cgi = $req->cgi;
4708
4709   my @files = $self->get_files($article);
4710
4711   my $id = $cgi->param('file_id');
4712
4713   my ($file) = grep $_->{id} == $id, @files
4714     or return $self->edit_form($req, $article, $articles,
4715                                "No such file");
4716   $req->user_can(edit_files_save => $article)
4717     or return $self->edit_form($req, $article, $articles,
4718                                "You don't have access to save file information for this article");
4719   my @other_files = grep $_->{id} != $id, @files;
4720
4721   my $download_path = BSE::TB::ArticleFiles->download_path($self->{cfg});
4722
4723   my %errors;
4724
4725   $req->validate(errors => \%errors,
4726                  fields => \%file_fields,
4727                  section => $article->{id} == -1 ? 'Global File Validation' : 'Article File Validation');
4728
4729   my $store_anyway = 0;
4730   my $desc = $cgi->param("description");
4731   defined $desc and $file->{description} = $desc;
4732   my $type = $cgi->param("contentType");
4733   if (defined $type && $file->{contentType} ne $type) {
4734     ++$store_anyway;
4735     $file->{contentType} = $type;
4736   }
4737   my $notes = $cgi->param("notes");
4738   defined $notes and $file->{notes} = $notes;
4739   my $name = $cgi->param("name");
4740   require BSE::ImageSize;
4741   if (defined $name) {
4742     $file->{name} = $name;
4743     if (length $name) {
4744       if ($name =~ /^\w+$/) {
4745         if (grep lc $name eq lc $_->{name}, @other_files) {
4746           $errors{name} = 'File identifier must be unique to the article';
4747         }
4748       }
4749       else {
4750         $errors{name} = "Invalid file identifier $name";
4751       }
4752     }
4753   }
4754
4755   require BSE::FileMetaMeta;
4756   my $meta = BSE::FileMetaMeta->retrieve($req, $file, \%errors);
4757
4758   if ($cgi->param('save_file_flags')) {
4759     my $download = 0 + defined $cgi->param("download");
4760     if ($download ne $file->{download}) {
4761       ++$store_anyway;
4762       $file->{download}     = $download;
4763     }
4764     $file->{forSale}        = 0 + defined $cgi->param("forSale");
4765     $file->{requireUser}    = 0 + defined $cgi->param("requireUser");
4766     $file->{hide_from_list} = 0 + defined $cgi->param("hide_from_list");
4767   }
4768
4769   my @old_file;
4770   my @new_files;
4771   my $filex = $cgi->param("file");
4772   my $in_fh = $cgi->upload("file");
4773   if (defined $filex && length $filex) {
4774     if ($in_fh) {
4775       if (-s $in_fh) {
4776         require DevHelp::FileUpload;
4777         my $msg;
4778         my ($file_name, $out_fh) = DevHelp::FileUpload->make_img_filename
4779           ($download_path, $filex . '', \$msg);
4780         if ($file_name) {
4781           {
4782             local $/ = \8192;
4783             my $data;
4784             while ($data = <$in_fh>) {
4785               print $out_fh $data;
4786             }
4787             close $out_fh;
4788           }
4789           my $display_name = $filex;
4790           $display_name =~ s!.*[\\:/]!!;
4791           $display_name =~ s/[^\w._-]+/_/g;
4792           my $full_name = "$download_path/$file_name";
4793           @old_file = ( $file->{filename}, $file->{storage} );
4794           push @new_files, $file_name;
4795
4796           $file->{filename} = $file_name;
4797           $file->{sizeInBytes} = -s $full_name;
4798           $file->{whenUploaded} = now_sqldatetime();
4799           $file->{displayName} = $display_name;
4800           $file->{storage} = 'local';
4801         }
4802         else {
4803           $errors{"file"} = $msg;
4804         }
4805       }
4806       else {
4807         $errors{"file"} = "File is empty";
4808       }
4809     }
4810     else {
4811       $errors{"file"} = "No file data received";
4812     }
4813   }
4814
4815   if (keys %errors) {
4816     # remove the uploaded replacements
4817     unlink map "$download_path/$_", @new_files;
4818
4819     return $self->req_edit_file($req, $article, $articles, \%errors);
4820   }
4821   $file->save;
4822
4823   $file->set_handler($self->cfg);
4824   $file->save;
4825
4826   $req->flash("msg:bse/admin/edit/file/save/success", [ $file->displayName ]);
4827   my $mgr = $self->_file_manager($self->cfg);
4828
4829   my $storage = $cgi->param('storage');
4830   defined $storage or $storage = $file->{storage};
4831   my $msg;
4832   $storage = $article->select_filestore($mgr, $file, $storage, \$msg);
4833   $msg and $req->flash($msg);
4834   if ($storage ne $file->{storage} || $store_anyway) {
4835     my $old_storage = $file->{storage};
4836     eval {
4837       $file->{src} = $mgr->store($file->{filename}, $storage, $file);
4838       $file->{storage} = $storage;
4839       $file->save;
4840
4841       $mgr->unstore($file->{filename}, $old_storage)
4842         if $old_storage ne $storage;
4843     };
4844     $@
4845       and $req->flash("Could not move $file->{displayName} to $storage: $@");
4846   }
4847
4848   BSE::FileMetaMeta->save($file, $meta);
4849
4850   # remove the replaced files
4851   if (my ($old_name, $old_storage) = @old_file) {
4852     $mgr->unstore($old_name, $old_storage);
4853     unlink "$download_path/$old_name";
4854   }
4855
4856   generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4857
4858   $self->_refresh_filelist($req, $article);
4859 }
4860
4861 sub can_remove {
4862   my ($self, $req, $article, $articles, $rmsg, $rcode) = @_;
4863
4864   unless ($req->user_can('edit_delete_article', $article, $rmsg)) {
4865     $$rmsg ||= "Access denied";
4866     $$rcode = "ACCESS";
4867     return;
4868   }
4869
4870   if ($articles->children($article->{id})) {
4871     $$rmsg = "This article has children.  You must delete the children first (or change their parents)";
4872     $$rcode = "CHILDREN";
4873     return;
4874   }
4875   if (grep($_ == $article->{id}, @Constants::NO_DELETE)
4876      || $req->cfg->entry("undeletable articles", $article->{id})) {
4877     $$rmsg = "Sorry, these pages are essential to the site structure - they cannot be deleted";
4878     $$rcode = "ESSENTIAL";
4879     return;
4880   }
4881   if ($article->{id} == $Constants::SHOPID) {
4882     $$rmsg = "Sorry, these pages are essential to the store - they cannot be deleted - you may want to hide the store instead.";
4883     $$rcode = "SHOP";
4884     return;
4885   }
4886
4887   return 1;
4888 }
4889
4890 =item remove
4891
4892 Error codes:
4893
4894 =over
4895
4896 =item *
4897
4898 ACCESS - access denied
4899
4900 =item *
4901
4902 CHILDREN - the article has children
4903
4904 =item *
4905
4906 ESSENTIAL - the article is marked essential
4907
4908 =item *
4909
4910 SHOP - the article is an essential part of the shop (the shop article
4911 itself)
4912
4913 =back
4914
4915 JSON success response: { success: 1, article_id: I<id> }
4916
4917 =cut
4918
4919 sub remove {
4920   my ($self, $req, $article, $articles) = @_;
4921
4922   $req->check_csrf("admin_remove_article")
4923     or return $self->csrf_error($req, $article, "admin_remove_article", "Remove Article");
4924
4925   my $why_not;
4926   my $code;
4927   unless ($self->can_remove($req, $article, $articles, \$why_not, \$code)) {
4928     return $self->_service_error($req, $article, $articles, $why_not, {}, $code);
4929   }
4930
4931   my $data = $article->data_only;
4932
4933   my $parentid = $article->{parentid};
4934   $article->remove($req->cfg);
4935
4936   if ($req->is_ajax) {
4937     return $req->json_content
4938       (
4939        success => 1,
4940        article_id => $data->{id},
4941       );
4942   }
4943
4944   my $url = $req->cgi->param('r');
4945   unless ($url) {
4946     $url = $req->cfg->admin_url("add", { id => $parentid });
4947   }
4948
4949   $req->flash_notice("msg:bse/admin/edit/remove", [ $data ]);
4950
4951   return BSE::Template->get_refresh($url, $self->{cfg});
4952 }
4953
4954 sub unhide {
4955   my ($self, $req, $article, $articles) = @_;
4956
4957   $req->check_csrf("admin_save_article")
4958     or return $self->csrf_error($req, $article, "admin_save_article", "Unhide article");
4959
4960   if ($req->user_can(edit_field_edit_listed => $article)
4961       && $req->user_can(edit_save => $article)) {
4962     $article->{listed} = 1;
4963     $article->save;
4964
4965     generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4966   }
4967   return $self->refresh($article, $req->cgi, undef, 'Article unhidden');
4968 }
4969
4970 sub hide {
4971   my ($self, $req, $article, $articles) = @_;
4972
4973   $req->check_csrf("admin_save_article")
4974     or return $self->csrf_error($req, $article, "admin_save_article", "Hide article");
4975
4976   if ($req->user_can(edit_field_edit_listed => $article)
4977       && $req->user_can(edit_save => $article)) {
4978     $article->{listed} = 0;
4979     $article->save;
4980
4981     generate_article($articles, $article) if $Constants::AUTO_GENERATE;
4982   }
4983   my $r = $req->cgi->param('r');
4984   unless ($r) {
4985     $r = admin_base_url($req->cfg)
4986       . "/cgi-bin/admin/add.pl?id=" . $article->{parentid};
4987   }
4988   return $self->refresh($article, $req->cgi, undef, 'Article hidden');
4989 }
4990
4991 my %defaults =
4992   (
4993    titleImage => '',
4994    imagePos => 'tr',
4995    expire => $Constants::D_99,
4996    listed => 1,
4997    keyword => '',
4998    body => '<maximum of 64Kb>',
4999    force_dynamic => 0,
5000    inherit_siteuser_rights => 1,
5001    menu => 0,
5002    titleAlias => '',
5003    linkAlias => '',
5004    author => '',
5005    summary => '',
5006    category => '',
5007   );
5008
5009 sub default_value {
5010   my ($self, $req, $article, $col) = @_;
5011
5012   if ($article->{parentid}) {
5013     my $section = "children of $article->{parentid}";
5014     my $value = $req->cfg->entry($section, $col);
5015     if (defined $value) {
5016       return $value;
5017     }
5018   }
5019   my $section = "level $article->{level}";
5020   my $value = $req->cfg->entry($section, $col);
5021   defined($value) and return $value;
5022
5023   $value = $self->type_default_value($req, $col);
5024   defined $value and return $value;
5025
5026   exists $defaults{$col} and return $defaults{$col};
5027
5028   $col eq 'release' and return now_sqldate();
5029
5030   if ($col eq 'threshold') {
5031     my $parent = defined $article->{parentid} && $article->{parentid} != -1
5032       && BSE::TB::Articles->getByPkey($article->{parentid});
5033
5034     $parent and return $parent->{threshold};
5035
5036     return 5;
5037   }
5038
5039   if ($col eq 'summaryLength') {
5040     my $parent = defined $article->{parentid} && $article->{parentid} != -1
5041       && BSE::TB::Articles->getByPkey($article->{parentid});
5042
5043     $parent and return $parent->{summaryLength};
5044
5045     return 200;
5046   }
5047
5048   return;
5049 }
5050
5051 sub type_default_value {
5052   my ($self, $req, $col) = @_;
5053
5054   return $req->cfg->entry('article defaults', $col);
5055 }
5056
5057 sub flag_sections {
5058   return ( 'article flags' );
5059 }
5060
5061 sub flags {
5062   my ($self) = @_;
5063
5064   my $cfg = $self->{cfg};
5065
5066   my @sections = $self->flag_sections;
5067
5068   my %flags = map $cfg->entriesCS($_), reverse @sections;
5069   my @valid = grep /^\w$/, keys %flags;
5070
5071   return map +{ id => $_, desc => $flags{$_} },
5072     sort { lc($flags{$a}) cmp lc($flags{$b}) }@valid;
5073 }
5074
5075 sub get_images {
5076   my ($self, $article) = @_;
5077
5078   $article->images;
5079 }
5080
5081 sub validate_image_name {
5082   my ($self, $name, $rmsg) = @_;
5083
5084   1; # no extra validation
5085 }
5086
5087 sub req_ajax_get {
5088   my ($self, $req, $article, $articles, @extras) = @_;
5089
5090   my $field_name = $req->cgi->param('field');
5091   unless ($field_name && exists $article->{$field_name}) {
5092     print STDERR "req_ajax_get: missing or invalid field parameter\n";
5093     return {
5094             content => 'Invalid or missing field name',
5095             headers => [
5096                         "Status: 187" # bad request
5097                        ],
5098            };
5099   }
5100
5101   my $value = $article->{$field_name};
5102   defined $value or $value = '';
5103
5104   my $charset = $req->cfg->entry('html', 'charset', 'iso-8859-1');
5105
5106   # re-encode to utf8
5107   require Encode;
5108   Encode::from_to($value, $charset, 'utf8');
5109
5110   # make some content
5111   return
5112     {
5113      content => $value,
5114      type => 'text/plain; charset=utf-8',
5115     };
5116 }
5117
5118 sub req_ajax_save_body {
5119    my ($self, $req, $article, $articles, @extras) = @_;
5120
5121    my $cfg = $req->cfg;
5122    my $cgi = $req->cgi;
5123
5124    unless ($req->user_can("edit_save", $article)
5125            && $req->user_can("edit_field_edit_body", $article)) {
5126     return {
5127             content => "Access denied to body",
5128             headers => [
5129                         "Status: 187" # bad request
5130                        ],
5131            };
5132    }
5133
5134    require Encode;
5135    # ajax always sends in UTF-8
5136    my $body = Encode::decode(utf8 => $cgi->param('body'));
5137
5138    my $charset = $req->cfg->entry('html', 'charset', 'iso-8859-1');
5139
5140    # convert it to our working charset
5141    # any characters that don't convert are replaced by some
5142    # substitution character, not defined by the documentation
5143    $body = Encode::encode($charset, $body);
5144
5145    $article->{body} = $body;
5146    $article->{lastModified} = now_sqldatetime();
5147    my $user = $req->getuser;
5148    $article->{lastModifiedBy} = $user ? $user->{logon} : '';
5149    $article->save;
5150
5151    my @extra_regen;
5152    @extra_regen = $self->update_child_dynamic($article, $articles, $req);
5153
5154    if ($Constants::AUTO_GENERATE) {
5155      require Util;
5156      generate_article($articles, $article);
5157      for my $regen_id (@extra_regen) {
5158        my $regen = $articles->getByPkey($regen_id);
5159        BSE::Regen::generate_low($articles, $regen, $self->{cfg});
5160      }
5161    }
5162
5163    # we need the formatted body as the result
5164    my $genname = $article->{generator};
5165    eval "use $genname";
5166    $@ and die "Error on use $genname: $@";
5167    my $gen = $genname->new(article => $articles, cfg => $cfg, top => $article);
5168    my %acts;
5169    %acts = $gen->baseActs($articles, \%acts, $article, 0);
5170    my $template = "<:body:>";
5171    my $formatted = BSE::Template->replace($template, $req->cfg, \%acts);
5172
5173    return
5174      {
5175       content => $formatted,
5176       type => BSE::Template->html_type($cfg),
5177      };
5178 }
5179
5180 sub iter_file_metas {
5181   my ($self, $files, $rfile_index) = @_;
5182
5183   $$rfile_index < 0 || $$rfile_index >= @$files
5184     and return;
5185
5186   my $file = $files->[$$rfile_index];
5187
5188   return $file->text_metadata;
5189 }
5190
5191 my %settable_fields = qw(title keyword author pageTitle);
5192
5193
5194 sub req_ajax_set {
5195    my ($self, $req, $article, $articles, @extras) = @_;
5196
5197    my $cfg = $req->cfg;
5198    my $cgi = $req->cgi;
5199
5200    my $field = $cgi->param('field');
5201
5202    unless ($field && $settable_fields{$field}) {
5203     return {
5204             content => 'Invalid or missing field name',
5205             headers => [
5206                         "Status: 187" # bad request
5207                        ],
5208            };
5209    }
5210    unless ($req->user_can("edit_save", $article)
5211            && $req->user_can("edit_field_edit_$field", $article)) {
5212     return {
5213             content => "Access denied to $field",
5214             headers => [
5215                         "Status: 187" # bad request
5216                        ],
5217            };
5218    }
5219
5220    require Encode;
5221    # ajax always sends in UTF-8
5222    my $value = Encode::decode(utf8 => $cgi->param('value'));
5223
5224    # hack - validate it if it's the title
5225    if ($field eq 'title') {
5226      if ($value !~ /\S/) {
5227        return {
5228                content => 'Invelid or missing field name',
5229                headers => [
5230                            "Status: 187" # bad request
5231                           ],
5232               };
5233      }
5234    }
5235
5236    my $charset = $req->cfg->entry('html', 'charset', 'iso-8859-1');
5237
5238    # convert it to our working charset
5239    # any characters that don't convert are replaced by some
5240    # substitution character, not defined by the documentation
5241    $value = Encode::encode($charset, $value);
5242
5243    $article->{$field} = $value;
5244    $article->{lastModified} = now_sqldatetime();
5245    my $user = $req->getuser;
5246    $article->{lastModifiedBy} = $user ? $user->{logon} : '';
5247    $article->save;
5248
5249    my @extra_regen;
5250    @extra_regen = $self->update_child_dynamic($article, $articles, $req);
5251
5252    if ($Constants::AUTO_GENERATE) {
5253      require Util;
5254      generate_article($articles, $article);
5255      for my $regen_id (@extra_regen) {
5256        my $regen = $articles->getByPkey($regen_id);
5257        BSE::Regen::generate_low($articles, $regen, $self->{cfg});
5258      }
5259    }
5260
5261    return
5262      {
5263       content => $value,
5264       type => BSE::Template->html_type($cfg),
5265      };
5266 }
5267
5268 sub csrf_error {
5269   my ($self, $req, $article, $name, $description) = @_;
5270
5271   my %errors;
5272   my $msg = $req->csrf_error;
5273   $errors{_csrfp} = $msg;
5274   my $mymsg;
5275   $article ||= $self->_dummy_article($req, 'BSE::TB::Articles', \$mymsg);
5276   unless ($article) {
5277     require BSE::Edit::Site;
5278     my $site = BSE::Edit::Site->new(cfg=>$req->cfg, db=> BSE::DB->single);
5279     return $site->edit_sections($req, 'BSE::TB::Articles', $mymsg);
5280   }
5281   return $self->_service_error($req, $article, 'BSE::TB::Articles', $msg, \%errors);
5282 }
5283
5284 =item a_csrp
5285
5286 Returns the csrf token for a given action.
5287
5288 Must only be callable from Ajax requests.
5289
5290 In general Ajax requests won't require a token, but some types of
5291 requests initiated by an Ajax based client might need a token, in
5292 particular: file uploads.
5293
5294 =cut
5295
5296 sub req_csrfp {
5297   my ($self, $req, $article, $articles) = @_;
5298
5299   $req->is_ajax
5300     or return $self->_service_error($req, $article, $articles,
5301                                     "Only usable from Ajax", undef, "NOTAJAX");
5302
5303   $ENV{REQUEST_METHOD} eq 'POST'
5304     or return $self->_service_error($req, $article, "BSE::TB::Articles",
5305                                     "POST required for this action", {}, "NOTPOST");
5306
5307   my %errors;
5308   my (@names) = $req->cgi->param("name");
5309   @names or $errors{name} = "Missing parameter 'name'";
5310   unless ($errors{name}) {
5311     for my $name (@names) {
5312       $name =~ /^\w+\z/
5313         or $errors{name} = "Invalid name: must be an identifier";
5314     }
5315   }
5316
5317   keys %errors
5318     and return $self->_service_error($req, $article, $articles,
5319                                      "Invalid parameter", \%errors, "FIELD");
5320
5321   return $req->json_content
5322     (
5323      {
5324       success => 1,
5325       tokens =>
5326       {
5327        map { $_ => $req->get_csrf_token($_) } @names,
5328       },
5329      },
5330     );
5331 }
5332
5333 sub _article_kid_summary {
5334   my ($article_id, $depth) = @_;
5335
5336   my @kids = BSE::DB->query(bseArticleKidSummary => $article_id);
5337   if (--$depth > 0) {
5338     for my $kid (@kids) {
5339       $kid->{children} = [ _article_kid_summary($kid->{id}, $depth) ];
5340       $kid->{allkids} = [ BSE::TB::Articles->allkid_summary($kid->{id}) ];
5341     }
5342   }
5343
5344   return @kids;
5345 }
5346
5347 =item a_tree
5348
5349 Returns a JSON tree of articles.
5350
5351 Requires an article id (-1 to start from the root).
5352
5353 Takes an optional tree depth.  1 only shows immediate children of the
5354 article.
5355
5356 =cut
5357
5358 sub req_tree {
5359   my ($self, $req, $article, $articles) = @_;
5360
5361   my $depth = $req->cgi->param("depth");
5362   defined $depth && $depth =~ /^\d+$/ and $depth >= 1
5363     or $depth = 10000; # something large
5364
5365   $req->is_ajax
5366     or return $self->_service_error($req, $article, $articles, "Only available to Ajax requests", {}, "NOTAJAX");
5367
5368   return $req->json_content
5369     (
5370      success => 1,
5371      articles =>
5372      [
5373       _article_kid_summary($article->id, $depth),
5374      ],
5375      allkids =>
5376      [
5377       BSE::TB::Articles->allkid_summary($article->id)
5378      ],
5379     );
5380 }
5381
5382 =item a_article
5383
5384 Returns the article as JSON.
5385
5386 Populates images with images and files with files.
5387
5388 The article data is in the article member of the returned object.
5389
5390 =cut
5391
5392 sub req_article {
5393   my ($self, $req, $article, $articles) = @_;
5394
5395   $req->is_ajax
5396     or return $self->_service_error($req, $article, $articles, "Only available to Ajax requests", {}, "NOTAJAX");
5397
5398   return $req->json_content
5399     (
5400      success => 1,
5401      article => $self->_article_data($req, $article),
5402     );
5403 }
5404
5405 sub templates_long {
5406   my ($self, $article) = @_;
5407
5408   my @templates = $self->templates($article);
5409
5410   my $cfg = $self->{cfg};
5411   return map
5412     +{
5413       name => $_,
5414       description => $cfg->entry("template descriptions", $_, $_),
5415      }, @templates;
5416 }
5417
5418 sub _populate_config {
5419   my ($self, $req, $article, $articles, $conf) = @_;
5420
5421   my $cfg = $req->cfg;
5422   my %geos = $cfg->entries("thumb geometries");
5423   my %defaults;
5424   my @cols = $self->table_object($articles)->rowClass->columns;
5425   shift @cols;
5426   for my $col (@cols) {
5427     my $def = $self->default_value($req, $article, $col);
5428     defined $def and $defaults{$col} = $def;
5429   }
5430   my @templates = $self->templates($article);
5431   $defaults{template} =
5432     $self->default_template($article, $req->cfg, \@templates);
5433
5434   $conf->{templates} = [ $self->templates_long($article) ];
5435   $conf->{thumb_geometries} =
5436     [
5437      map
5438      {
5439        +{
5440          name => $_,
5441          description => $cfg->entry("thumb geometry $_", "description", $_),
5442         };
5443      } sort keys %geos
5444     ];
5445   $conf->{defaults} = \%defaults;
5446   $conf->{upload_progress} = $req->_tracking_uploads;
5447   my @child_types = $self->child_types($article);
5448   s/^BSE::Edit::// for @child_types;
5449   $conf->{child_types} = \@child_types;
5450   $conf->{flags} = [ $self->flags ];
5451 }
5452
5453 =item a_config
5454
5455 Returns configuration information as JSON.
5456
5457 Returns an object of the form:
5458
5459   {
5460     success: 1,
5461     templates:
5462     [
5463       "template.tmpl":
5464       {
5465         description: "template.tmpl", // or from [template descriptions]
5466       },
5467       ...
5468     ],
5469     thumb_geometries:
5470     [
5471       "geoid":
5472       {
5473         description: "geoid", // or from [thumb geometry id].description
5474       },
5475     ],
5476     defaults:
5477     {
5478       field: value,
5479       ...
5480     },
5481     child_types: [ "Article" ],
5482     flags:
5483     [
5484       { id => "A", desc => "description" },
5485       ...
5486     ],
5487     // possibible custom data
5488   }
5489
5490 To define custom data add entries to the [extra a_config] section,
5491 keys become the keys in the returned structure pointing at hashes
5492 containing that section from the system configuration.  Custom keys
5493 may not conflict with system defined keys.
5494
5495 =cut
5496
5497 sub req_config {
5498   my ($self, $req, $article, $articles) = @_;
5499
5500   $req->is_ajax
5501     or return $self->_service_error($req, $article, $articles, "Only available to Ajax requests", {}, "NOTAJAX");
5502
5503   my %conf;
5504   $self->_populate_config($req, $article, $articles, \%conf);
5505   $conf{success} = 1;
5506
5507   my $cfg = $req->cfg;
5508   my %custom = $cfg->entries("extra a_config");
5509   for my $key (keys %custom) {
5510     exists $conf{$key} and next;
5511
5512     my $section = $custom{$key};
5513     $section =~ s/\{(level|generator|parentid|template)\}/$article->{$1}/g;
5514
5515     $section eq "db" and die;
5516
5517     $conf{$key} = { $cfg->entries($section) };
5518   }
5519
5520   return $req->json_content
5521     (
5522      \%conf
5523     );
5524 }
5525
5526 1;
5527
5528 =back
5529
5530 =head1 AUTHOR
5531
5532 Tony Cook <tony@develop-help.com>
5533
5534 =head1 REVISION
5535
5536 $Revision$
5537
5538 =cut