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