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