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