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