site/cgi-bin/modules/BSE/Edit/Article.pm

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