allow a_csrfp to work on the site
[bse.git] / site / cgi-bin / modules / BSE / Edit / Article.pm
CommitLineData
ca9aa2bf
TC
1package BSE::Edit::Article;
2use strict;
ca9aa2bf 3use base qw(BSE::Edit::Base);
b553afa2 4use BSE::Util::Tags qw(tag_error_img);
41f10371 5use BSE::Util::SQL qw(now_sqldate now_sqldatetime);
b553afa2 6use BSE::Util::Valid qw/valid_date/;
9168c88c 7use BSE::Permissions;
d09682dd
TC
8use DevHelp::HTML qw(:default popup_menu);
9use BSE::Arrows;
ab2cd916
TC
10use BSE::CfgInfo qw(custom_class admin_base_url cfg_image_dir);
11use BSE::Util::Iterate;
f2bf0d11 12use BSE::Template;
e63c3728 13use BSE::Util::ContentType qw(content_type);
4b69925d 14use constant MAX_FILE_DISPLAYNAME_LENGTH => 255;
ca9aa2bf 15
58baa27b
TC
16=head1 NAME
17
18 BSE::Edit::Article - editing functionality for BSE articles
19
20=head1 DESCRIPTION
21
22Provides the base article editing functionality.
23
24This is badly organized and documented.
25
26=head1 METHODS
27
28=over
29
30=cut
31
74b21f6d
TC
32sub not_logged_on {
33 my ($self, $req) = @_;
34
9b3a5df0 35 if ($req->is_ajax) {
74b21f6d 36 # AJAX/Prototype request
9b3a5df0
TC
37 return $req->json_content
38 (
39 {
60bc6601 40 success => 0,
9b3a5df0
TC
41 message => "Access forbidden: user not logged on",
42 errors => {},
60bc6601 43 error_code => "LOGON",
9b3a5df0
TC
44 }
45 );
46 }
47 elsif ($req->cgi->param('_service')) {
74b21f6d
TC
48 return
49 {
50 content => 'Access Forbidden: login timed out',
51 headers => [
52 "Status: 403", # forbidden
53 ],
54 };
55 }
56 else {
57 BSE::Template->get_refresh($req->url('logon'), $req->cfg);
58 }
59}
60
ca9aa2bf 61sub article_dispatch {
9168c88c
TC
62 my ($self, $req, $article, $articles) = @_;
63
64 BSE::Permissions->check_logon($req)
fc186852 65 or return $self->not_logged_on($req);
9168c88c
TC
66
67 my $cgi = $req->cgi;
ca9aa2bf
TC
68 my $action;
69 my %actions = $self->article_actions;
70 for my $check (keys %actions) {
71 if ($cgi->param($check) || $cgi->param("$check.x")) {
72 $action = $check;
73 last;
74 }
75 }
76 my @extraargs;
77 unless ($action) {
78 ($action, @extraargs) = $self->other_article_actions($cgi);
79 }
80 $action ||= 'edit';
81 my $method = $actions{$action};
9168c88c 82 return $self->$method($req, $article, $articles, @extraargs);
ca9aa2bf
TC
83}
84
85sub noarticle_dispatch {
9168c88c 86 my ($self, $req, $articles) = @_;
ca9aa2bf 87
9168c88c
TC
88 BSE::Permissions->check_logon($req)
89 or return BSE::Template->get_refresh($req->url('logon'), $req->cfg);
90
91 my $cgi = $req->cgi;
ca9aa2bf
TC
92 my $action = 'add';
93 my %actions = $self->noarticle_actions;
94 for my $check (keys %actions) {
95 if ($cgi->param($check) || $cgi->param("$check.x")) {
96 $action = $check;
97 last;
98 }
99 }
100 my $method = $actions{$action};
9168c88c 101 return $self->$method($req, $articles);
ca9aa2bf
TC
102}
103
ca9aa2bf
TC
104sub article_actions {
105 my ($self) = @_;
106
107 return
108 (
109 edit => 'edit_form',
110 save => 'save',
111 add_stepkid => 'add_stepkid',
112 del_stepkid => 'del_stepkid',
113 save_stepkids => 'save_stepkids',
114 add_stepparent => 'add_stepparent',
115 del_stepparent => 'del_stepparent',
116 save_stepparents => 'save_stepparents',
117 artimg => 'save_image_changes',
118 addimg => 'add_image',
b95fc3a0
TC
119 a_edit_image => 'req_edit_image',
120 a_save_image => 'req_save_image',
6473c56f 121 remove => 'remove',
ca9aa2bf
TC
122 showimages => 'show_images',
123 process => 'save_image_changes',
124 removeimg => 'remove_img',
125 moveimgup => 'move_img_up',
126 moveimgdown => 'move_img_down',
127 filelist => 'filelist',
128 fileadd => 'fileadd',
129 fileswap => 'fileswap',
130 filedel => 'filedel',
131 filesave => 'filesave',
b2a9e505
TC
132 a_edit_file => 'req_edit_file',
133 a_save_file => 'req_save_file',
4010d92e
TC
134 hide => 'hide',
135 unhide => 'unhide',
ab2cd916 136 a_thumb => 'req_thumb',
74b21f6d
TC
137 a_ajax_get => 'req_ajax_get',
138 a_ajax_save_body => 'req_ajax_save_body',
139 a_ajax_set => 'req_ajax_set',
36e373a9 140 a_filemeta => 'req_filemeta',
f3fc60c0 141 a_csrfp => 'req_csrfp',
60bc6601 142 a_tree => 'req_tree',
ca9aa2bf
TC
143 );
144}
145
146sub other_article_actions {
147 my ($self, $cgi) = @_;
148
149 for my $param ($cgi->param) {
150 if ($param =~ /^removeimg_(\d+)(\.x)?$/) {
151 return ('removeimg', $1 );
152 }
153 }
154
155 return;
156}
157
158sub noarticle_actions {
159 return
160 (
161 add => 'add_form',
162 save => 'save_new',
f3fc60c0 163 a_csrfp => 'req_csrfp',
ca9aa2bf
TC
164 );
165}
166
167sub get_parent {
168 my ($self, $parentid, $articles) = @_;
169
170 if ($parentid == -1) {
171 return
172 {
173 id => -1,
174 title=>'All Sections',
175 level => 0,
176 listed => 0,
177 parentid => undef,
178 };
179 }
180 else {
181 return $articles->getByPkey($parentid);
182 }
183}
184
185sub tag_hash {
186 my ($object, $args) = @_;
187
188 my $value = $object->{$args};
189 defined $value or $value = '';
7b81711b
TC
190 if ($value =~ /\cJ/ && $value =~ /\cM/) {
191 $value =~ tr/\cM//d;
192 }
77804754 193 escape_html($value);
ca9aa2bf
TC
194}
195
62533efa
TC
196sub tag_hash_mbcs {
197 my ($object, $args) = @_;
198
199 my $value = $object->{$args};
200 defined $value or $value = '';
201 if ($value =~ /\cJ/ && $value =~ /\cM/) {
202 $value =~ tr/\cM//d;
203 }
204 escape_html($value, '<>&"');
205}
206
ca9aa2bf
TC
207sub tag_art_type {
208 my ($level, $cfg) = @_;
209
77804754 210 escape_html($cfg->entry('level names', $level, 'Article'));
ca9aa2bf
TC
211}
212
213sub tag_if_new {
214 my ($article) = @_;
215
216 !$article->{id};
217}
218
219sub reparent_updown {
220 return 1;
221}
222
223sub should_be_catalog {
224 my ($self, $article, $parent, $articles) = @_;
225
226 if ($article->{parentid} && (!$parent || $parent->{id} != $article->{parentid})) {
227 $parent = $articles->getByPkey($article->{id});
228 }
229
6430ee52 230 my $shopid = $self->cfg->entryErr('articles', 'shop');
ca9aa2bf
TC
231
232 return $article->{parentid} && $parent &&
233 ($article->{parentid} == $shopid ||
234 $parent->{generator} eq 'Generate::Catalog');
235}
236
237sub possible_parents {
9168c88c 238 my ($self, $article, $articles, $req) = @_;
ca9aa2bf
TC
239
240 my %labels;
241 my @values;
242
6430ee52 243 my $shopid = $self->cfg->entryErr('articles', 'shop');
ca9aa2bf
TC
244 my @parents = $articles->getBy('level', $article->{level}-1);
245 @parents = grep { $_->{generator} eq 'Generate::Article'
246 && $_->{id} != $shopid } @parents;
9168c88c
TC
247
248 # user can only select parent they can add to
249 @parents = grep $req->user_can('edit_add_child', $_), @parents;
ca9aa2bf
TC
250
251 @values = ( map {$_->{id}} @parents );
252 %labels = ( map { $_->{id} => "$_->{title} ($_->{id})" } @parents );
253
9168c88c 254 if ($article->{level} == 1 && $req->user_can('edit_add_child')) {
ca9aa2bf
TC
255 push @values, -1;
256 $labels{-1} = "No parent - this is a section";
257 }
258
259 if ($article->{id} && $self->reparent_updown($article)) {
260 # we also list the siblings and grandparent (if any)
261 my @siblings = grep $_->{id} != $article->{id} && $_->{id} != $shopid,
262 $articles->getBy(parentid => $article->{parentid});
9168c88c 263 @siblings = grep $req->user_can('edit_add_child', $_), @siblings;
ca9aa2bf
TC
264 push @values, map $_->{id}, @siblings;
265 @labels{map $_->{id}, @siblings} =
266 map { "-- move down a level -- $_->{title} ($_->{id})" } @siblings;
267
268 if ($article->{parentid} != -1) {
269 my $parent = $articles->getByPkey($article->{parentid});
270 if ($parent->{parentid} != -1) {
271 my $gparent = $articles->getByPkey($parent->{parentid});
9168c88c
TC
272 if ($req->user_can('edit_add_child', $gparent)) {
273 push @values, $gparent->{id};
274 $labels{$gparent->{id}} =
275 "-- move up a level -- $gparent->{title} ($gparent->{id})";
276 }
ca9aa2bf
TC
277 }
278 else {
9168c88c
TC
279 if ($req->user_can('edit_add_child')) {
280 push @values, -1;
281 $labels{-1} = "-- move up a level -- become a section";
282 }
ca9aa2bf
TC
283 }
284 }
285 }
286
287 return (\@values, \%labels);
288}
289
290sub tag_list {
9168c88c 291 my ($self, $article, $articles, $cgi, $req, $what) = @_;
ca9aa2bf
TC
292
293 if ($what eq 'listed') {
294 my @values = qw(0 1);
295 my %labels = ( 0=>"No", 1=>"Yes");
296 if ($article->{level} <= 2) {
297 $labels{2} = "In Sections, but not menu";
298 push(@values, 2);
299 }
300 else {
301 $labels{2} = "In content, but not menus";
302 push(@values, 2);
303 }
d09682dd
TC
304 return popup_menu(-name=>'listed',
305 -values=>\@values,
306 -labels=>\%labels,
307 -default=>$article->{listed});
ca9aa2bf
TC
308 }
309 else {
9168c88c 310 my ($values, $labels) = $self->possible_parents($article, $articles, $req);
ca9aa2bf
TC
311 my $html;
312 if (defined $article->{parentid}) {
d09682dd
TC
313 $html = popup_menu(-name=>'parentid',
314 -values=> $values,
315 -labels => $labels,
316 -default => $article->{parentid},
317 -override=>1);
ca9aa2bf
TC
318 }
319 else {
d09682dd
TC
320 $html = popup_menu(-name=>'parentid',
321 -values=> $values,
322 -labels => $labels,
323 -override=>1);
ca9aa2bf
TC
324 }
325
326 # munge the html - we display a default value, so we need to wrap the
327 # default <select /> around this one
328 $html =~ s!^<select[^>]+>|</select>!!gi;
329 return $html;
330 }
331}
332
333sub tag_checked {
334 my ($arg, $acts, $funcname, $templater) = @_;
335 my ($func, $args) = split ' ', $arg, 2;
336 return $templater->perform($acts, $func, $args) ? 'checked' : '';
337}
338
339sub iter_get_images {
daee3409 340 my ($self, $article) = @_;
ca9aa2bf
TC
341
342 $article->{id} or return;
daee3409 343 $self->get_images($article);
ca9aa2bf
TC
344}
345
346sub iter_get_kids {
347 my ($article, $articles) = @_;
348
15fb10f2 349 my @children;
ca9aa2bf
TC
350 $article->{id} or return;
351 if (UNIVERSAL::isa($article, 'Article')) {
15fb10f2 352 @children = $article->children;
ca9aa2bf
TC
353 }
354 elsif ($article->{id}) {
15fb10f2 355 @children = $articles->children($article->{id});
ca9aa2bf 356 }
15fb10f2
TC
357
358 return sort { $b->{displayOrder} <=> $a->{displayOrder} } @children;
ca9aa2bf
TC
359}
360
361sub tag_if_have_child_type {
362 my ($level, $cfg) = @_;
363
364 defined $cfg->entry("level names", $level+1);
365}
366
367sub tag_is {
368 my ($args, $acts, $isname, $templater) = @_;
369
370 my ($func, $funcargs) = split ' ', $args, 2;
371 return $templater->perform($acts, $func, $funcargs) ? 'Yes' : 'No';
372}
373
caa7299c
TC
374sub default_template {
375 my ($self, $article, $cfg, $templates) = @_;
376
377 if ($article->{parentid}) {
378 my $template = $cfg->entry("children of $article->{parentid}", "template");
379 return $template
380 if $template && grep $_ eq $template, @$templates;
381 }
382 if ($article->{level}) {
383 my $template = $cfg->entry("level $article->{level}", "template");
384 return $template
385 if $template && grep $_ eq $template, @$templates;
386 }
387 return $templates->[0];
388}
389
ca9aa2bf
TC
390sub tag_templates {
391 my ($self, $article, $cfg, $cgi) = @_;
392
393 my @templates = sort $self->templates($article);
394 my $default;
395 if ($article->{template} && grep $_ eq $article->{template}, @templates) {
396 $default = $article->{template};
397 }
398 else {
caa7299c
TC
399 my @options;
400 $default = $self->default_template($article, $cfg, \@templates);
ca9aa2bf 401 }
d09682dd
TC
402 return popup_menu(-name=>'template',
403 -values=>\@templates,
404 -default=>$default,
405 -override=>1);
ca9aa2bf
TC
406}
407
408sub title_images {
409 my ($self, $article) = @_;
410
411 my @title_images;
6430ee52 412 my $imagedir = cfg_image_dir($self->cfg);
ca9aa2bf
TC
413 if (opendir TITLE_IMAGES, "$imagedir/titles") {
414 @title_images = sort
415 grep -f "$imagedir/titles/$_" && /\.(gif|jpeg|jpg|png)$/i,
416 readdir TITLE_IMAGES;
417 closedir TITLE_IMAGES;
418 }
419
420 @title_images;
421}
422
423sub tag_title_images {
424 my ($self, $article, $cfg, $cgi) = @_;
425
426 my @images = $self->title_images($article);
427 my @values = ( '', @images );
428 my %labels = ( '' => 'None', map { $_ => $_ } @images );
429 return $cgi->
430 popup_menu(-name=>'titleImage',
431 -values=>\@values,
432 -labels=>\%labels,
433 -default=>$article->{id} ? $article->{titleImage} : '',
434 -override=>1);
435}
436
437sub base_template_dirs {
438 return ( "common" );
439}
440
441sub template_dirs {
442 my ($self, $article) = @_;
443
444 my @dirs = $self->base_template_dirs;
445 if (my $parentid = $article->{parentid}) {
446 my $section = "children of $parentid";
6430ee52 447 if (my $dirs = $self->cfg->entry($section, 'template_dirs')) {
ca9aa2bf
TC
448 push @dirs, split /,/, $dirs;
449 }
450 }
451 if (my $id = $article->{id}) {
452 my $section = "article $id";
453 if (my $dirs = $self->{cfg}->entry($section, 'template_dirs')) {
454 push @dirs, split /,/, $dirs;
455 }
456 }
caa7299c
TC
457 if ($article->{level}) {
458 push @dirs, $article->{level};
459 my $dirs = $self->{cfg}->entry("level $article->{level}", 'template_dirs');
460 push @dirs, split /,/, $dirs if $dirs;
461 }
ca9aa2bf
TC
462
463 @dirs;
464}
465
466sub templates {
467 my ($self, $article) = @_;
468
469 my @dirs = $self->template_dirs($article);
470 my @templates;
918735d1
TC
471 my @basedirs = BSE::Template->template_dirs($self->{cfg});
472 for my $basedir (@basedirs) {
473 for my $dir (@dirs) {
474 my $path = File::Spec->catdir($basedir, $dir);
475 if (-d $path) {
476 if (opendir TEMPLATE_DIR, $path) {
477 push(@templates, sort map "$dir/$_",
478 grep -f "$path/$_" && /\.(tmpl|html)$/i, readdir TEMPLATE_DIR);
479 closedir TEMPLATE_DIR;
480 }
ca9aa2bf
TC
481 }
482 }
483 }
918735d1
TC
484
485 # eliminate any dups, and order it nicely
486 my %seen;
487 @templates = sort { lc($a) cmp lc($b) }
488 grep !$seen{$_}++, @templates;
489
ca9aa2bf
TC
490 return (@templates, $self->extra_templates($article));
491}
492
493sub extra_templates {
494 my ($self, $article) = @_;
495
aefcabcb 496 my $basedir = $self->{cfg}->entryVar('paths', 'templates');
ca9aa2bf
TC
497 my @templates;
498 if (my $id = $article->{id}) {
499 push @templates, 'index.tmpl'
500 if $id == 1 && -f "$basedir/index.html";
501 push @templates, 'index2.tmpl'
502 if $id == 2 && -f "$basedir/index2.html";
503 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
504 push @templates, "shop_sect.tmpl"
505 if $id == $shopid && -f "$basedir/shop_sect.tmpl";
506 my $section = "article $id";
507 my $extras = $self->{cfg}->entry($section, 'extra_templates');
508 push @templates, grep /\.(tmpl|html)$/i, split /,/, $extras
509 if $extras;
510 }
511
512 @templates;
513}
514
515sub edit_parent {
516 my ($article) = @_;
517
518 return '' unless $article->{id} && $article->{id} != -1;
519 return <<HTML;
520<a href="$ENV{SCRIPT_NAME}?id=$article->{parentid}">Edit parent</a> |
521HTML
522}
523
524sub iter_allkids {
525 my ($article) = @_;
526
527 return unless $article->{id} && $article->{id} > 0;
528 $article->allkids;
529}
530
531sub _load_step_kids {
532 my ($article, $step_kids) = @_;
533
534 my @stepkids = OtherParents->getBy(parentId=>$article->{id}) if $article->{id};
535 %$step_kids = map { $_->{childId} => $_ } @stepkids;
ca9aa2bf
TC
536 $step_kids->{loaded} = 1;
537}
538
539sub tag_if_step_kid {
540 my ($article, $allkids, $rallkid_index, $step_kids) = @_;
541
542 _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
543
544 my $kid = $allkids->[$$rallkid_index]
545 or return;
546 exists $step_kids->{$kid->{id}};
547}
548
549sub tag_step_kid {
550 my ($article, $allkids, $rallkid_index, $step_kids, $arg) = @_;
551
552 _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
553
554 my $kid = $allkids->[$$rallkid_index]
555 or return '';
f0543260
TC
556 my $step_kid = $step_kids->{$kid->{id}}
557 or return '';
558 #use Data::Dumper;
559 #print STDERR "found kid (want $arg): ", Dumper($kid), Dumper($step_kid);
560 escape_html($step_kid->{$arg});
ca9aa2bf
TC
561}
562
563sub tag_move_stepkid {
8b0b2f34
TC
564 my ($self, $cgi, $req, $article, $allkids, $rallkids_index, $arg,
565 $acts, $funcname, $templater) = @_;
31a26b52
TC
566
567 $req->user_can(edit_reorder_children => $article)
568 or return '';
ca9aa2bf 569
aefcabcb
TC
570 @$allkids > 1 or return '';
571
8b0b2f34
TC
572 my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
573 $img_prefix = '' unless defined $img_prefix;
574 $urladd = '' unless defined $urladd;
575
ca9aa2bf 576 my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
ca9aa2bf
TC
577 my $url = $ENV{SCRIPT_NAME} . "?id=$article->{id}";
578 if ($cgi->param('_t')) {
579 $url .= "&_t=".$cgi->param('_t');
580 }
8b0b2f34 581 $url .= $urladd;
ca9aa2bf 582 $url .= "#step";
d09682dd 583 my $down_url = '';
ca9aa2bf 584 if ($$rallkids_index < $#$allkids) {
d09682dd 585 $down_url = "$cgi_uri/admin/move.pl?stepparent=$article->{id}&d=swap&id=$allkids->[$$rallkids_index]{id}&other=$allkids->[$$rallkids_index+1]{id}";
aefcabcb 586 }
d09682dd 587 my $up_url = '';
ca9aa2bf 588 if ($$rallkids_index > 0) {
d09682dd 589 $up_url = "$cgi_uri/admin/move.pl?stepparent=$article->{id}&d=swap&id=$allkids->[$$rallkids_index]{id}&other=$allkids->[$$rallkids_index-1]{id}";
ca9aa2bf 590 }
d09682dd
TC
591
592 return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
ca9aa2bf
TC
593}
594
595sub possible_stepkids {
31a26b52
TC
596 my ($req, $article, $articles, $stepkids) = @_;
597
598 $req->user_can(edit_stepkid_add => $article)
599 or return;
ca9aa2bf 600
147e99e8
TC
601 $article->{id} == -1
602 and return;
603
31a26b52 604 my @possible = sort { lc $a->{title} cmp lc $b->{title} }
147e99e8
TC
605 $article->possible_stepchildren;
606 if ($req->access_control && $req->cfg->entry('basic', 'access_filter_steps', 0)) {
607 @possible = grep $req->user_can(edit_stepparent_add => $_->{id}), @possible;
31a26b52
TC
608 }
609 return @possible;
ca9aa2bf
TC
610}
611
ca9aa2bf 612sub tag_possible_stepkids {
31a26b52 613 my ($step_kids, $req, $article, $possstepkids, $articles, $cgi) = @_;
ca9aa2bf
TC
614
615 _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
31a26b52 616 @$possstepkids = possible_stepkids($req, $article, $articles, $step_kids)
ca9aa2bf
TC
617 unless @$possstepkids;
618 my %labels = map { $_->{id} => "$_->{title} ($_->{id})" } @$possstepkids;
619 return
d09682dd
TC
620 popup_menu(-name=>'stepkid',
621 -values=> [ map $_->{id}, @$possstepkids ],
622 -labels => \%labels);
ca9aa2bf
TC
623}
624
625sub tag_if_possible_stepkids {
31a26b52 626 my ($step_kids, $req, $article, $possstepkids, $articles, $cgi) = @_;
ca9aa2bf
TC
627
628 _load_step_kids($article, $step_kids) unless $step_kids->{loaded};
31a26b52 629 @$possstepkids = possible_stepkids($req, $article, $articles, $step_kids)
ca9aa2bf
TC
630 unless @$possstepkids;
631
632 @$possstepkids;
633}
634
635sub iter_get_stepparents {
636 my ($article) = @_;
637
638 return unless $article->{id} && $article->{id} > 0;
639
640 OtherParents->getBy(childId=>$article->{id});
641}
642
643sub tag_ifStepParents {
644 my ($args, $acts, $funcname, $templater) = @_;
645
646 return $templater->perform($acts, 'ifStepparents', '');
647}
648
649sub tag_stepparent_targ {
650 my ($article, $targs, $rindex, $arg) = @_;
651
652 if ($article->{id} && $article->{id} > 0 && !@$targs) {
653 @$targs = $article->step_parents;
654 }
77804754 655 escape_html($targs->[$$rindex]{$arg});
ca9aa2bf
TC
656}
657
658sub tag_move_stepparent {
8b0b2f34
TC
659 my ($self, $cgi, $req, $article, $stepparents, $rindex, $arg,
660 $acts, $funcname, $templater) = @_;
31a26b52
TC
661
662 $req->user_can(edit_reorder_stepparents => $article)
663 or return '';
ca9aa2bf 664
aefcabcb
TC
665 @$stepparents > 1 or return '';
666
8b0b2f34
TC
667 my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
668 $img_prefix = '' unless defined $img_prefix;
669 $urladd = '' unless defined $urladd;
670
ca9aa2bf
TC
671 my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
672 my $images_uri = $self->{cfg}->entry('uri', 'images', '/images');
673 my $html = '';
674 my $url = $ENV{SCRIPT_NAME} . "?id=$article->{id}";
675 if ($cgi->param('_t')) {
676 $url .= "&_t=".$cgi->param('_t');
677 }
8b0b2f34 678 $url .= $urladd;
ca9aa2bf 679 $url .= "#stepparents";
d794b180 680 my $blank = qq!<img src="$images_uri/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" alt="" />!;
d09682dd 681 my $down_url = '';
ca9aa2bf 682 if ($$rindex < $#$stepparents) {
d09682dd 683 $down_url = "$cgi_uri/admin/move.pl?stepchild=$article->{id}&id=$stepparents->[$$rindex]{parentId}&d=swap&other=$stepparents->[$$rindex+1]{parentId}";
aefcabcb 684 }
d09682dd 685 my $up_url = '';
ca9aa2bf 686 if ($$rindex > 0) {
d09682dd 687 $up_url = "$cgi_uri/admin/move.pl?stepchild=$article->{id}&id=$stepparents->[$$rindex]{parentId}&d=swap&other=$stepparents->[$$rindex-1]{parentId}";
aefcabcb 688 }
d09682dd
TC
689
690 return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
ca9aa2bf
TC
691}
692
de193691
TC
693sub _stepparent_possibles {
694 my ($req, $article, $articles, $targs) = @_;
695
696 $req->user_can(edit_stepparent_add => $article)
697 or return;
698
147e99e8
TC
699 $article->{id} == -1
700 and return;
701
de193691
TC
702 @$targs = $article->step_parents unless @$targs;
703 my %targs = map { $_->{id}, 1 } @$targs;
147e99e8
TC
704 my @possibles = $article->possible_stepparents;
705 if ($req->access_control && $req->cfg->entry('basic', 'access_filter_steps', 0)) {
706 @possibles = grep $req->user_can(edit_stepkid_add => $_->{id}), @possibles;
de193691
TC
707 }
708 @possibles = sort { lc $a->{title} cmp lc $b->{title} } @possibles;
709
710 return @possibles;
711}
712
ca9aa2bf 713sub tag_if_stepparent_possibles {
31a26b52 714 my ($req, $article, $articles, $targs, $possibles) = @_;
ca9aa2bf 715
de193691
TC
716 if ($article->{id} && $article->{id} > 0 && !@$possibles) {
717 @$possibles = _stepparent_possibles($req, $article, $articles, $targs);
ca9aa2bf
TC
718 }
719 scalar @$possibles;
720}
721
722sub tag_stepparent_possibles {
31a26b52 723 my ($cgi, $req, $article, $articles, $targs, $possibles) = @_;
ca9aa2bf 724
de193691
TC
725 if ($article->{id} && $article->{id} > 0 && !@$possibles) {
726 @$possibles = _stepparent_possibles($req, $article, $articles, $targs);
ca9aa2bf 727 }
d09682dd
TC
728 popup_menu(-name=>'stepparent',
729 -values => [ map $_->{id}, @$possibles ],
730 -labels => { map { $_->{id}, "$_->{title} ($_->{id})" }
731 @$possibles });
ca9aa2bf
TC
732}
733
734sub iter_files {
9366cd70
TC
735 my ($self, $article) = @_;
736
737 return $self->get_files($article);
738}
739
740sub get_files {
741 my ($self, $article) = @_;
ca9aa2bf
TC
742
743 return unless $article->{id} && $article->{id} > 0;
744
745 return $article->files;
746}
747
748sub tag_edit_parent {
749 my ($article) = @_;
750
751 return '' unless $article->{id} && $article->{id} != -1;
752
753 return <<HTML;
754<a href="$ENV{SCRIPT_NAME}?id=$article->{parentid}">Edit parent</a> |
755HTML
756}
757
758sub tag_if_children {
759 my ($args, $acts, $funcname, $templater) = @_;
760
761 return $templater->perform($acts, 'ifChildren', '');
762}
763
764sub tag_movechild {
8b0b2f34
TC
765 my ($self, $req, $article, $kids, $rindex, $arg,
766 $acts, $funcname, $templater) = @_;
abf5bbc6
TC
767
768 $req->user_can('edit_reorder_children', $article)
769 or return '';
ca9aa2bf 770
aefcabcb
TC
771 @$kids > 1 or return '';
772
ca9aa2bf
TC
773 $$rindex >=0 && $$rindex < @$kids
774 or return '** movechild can only be used in the children iterator **';
775
8b0b2f34
TC
776 my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
777 $img_prefix = '' unless defined $img_prefix;
778 $urladd = '' unless defined $urladd;
779
ca9aa2bf
TC
780 my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
781 my $images_uri = $self->{cfg}->entry('uri', 'images', '/images');
41f10371 782 my $urlbase = admin_base_url($req->cfg);
d09682dd 783 my $refresh_url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
cc9019d1
TC
784 my $t = $req->cgi->param('_t');
785 if ($t && $t =~ /^\w+$/) {
d09682dd 786 $refresh_url .= "&_t=$t";
cc9019d1 787 }
d09682dd
TC
788
789 $refresh_url .= $urladd;
790
ca9aa2bf 791 my $id = $kids->[$$rindex]{id};
d09682dd 792 my $down_url = '';
ca9aa2bf 793 if ($$rindex < $#$kids) {
d09682dd 794 $down_url = "$cgi_uri/admin/move.pl?id=$id&d=down&edit=1&all=1";
ca9aa2bf 795 }
d09682dd 796 my $up_url = '';
ca9aa2bf 797 if ($$rindex > 0) {
d09682dd 798 $up_url = "$cgi_uri/admin/move.pl?id=$id&d=up&edit=1&all=1"
ca9aa2bf 799 }
ca9aa2bf 800
d09682dd 801 return make_arrows($req->cfg, $down_url, $up_url, $refresh_url, $img_prefix);
ca9aa2bf
TC
802}
803
804sub tag_edit_link {
f2bf0d11 805 my ($cfg, $article, $args, $acts, $funcname, $templater) = @_;
ca9aa2bf
TC
806 my ($which, $name) = split / /, $args, 2;
807 $name ||= 'Edit';
808 my $gen_class;
809 if ($acts->{$which}
810 && ($gen_class = $templater->perform($acts, $which, 'generator'))) {
811 eval "use $gen_class";
812 unless ($@) {
f2bf0d11 813 my $gen = $gen_class->new(top => $article, cfg => $cfg);
ca9aa2bf
TC
814 my $link = $gen->edit_link($templater->perform($acts, $which, 'id'));
815 return qq!<a href="$link">$name</a>!;
816 }
817 }
818 return '';
819}
820
821sub tag_imgmove {
8b0b2f34
TC
822 my ($req, $article, $rindex, $images, $arg,
823 $acts, $funcname, $templater) = @_;
abf5bbc6
TC
824
825 $req->user_can(edit_images_reorder => $article)
826 or return '';
ca9aa2bf 827
aefcabcb
TC
828 @$images > 1 or return '';
829
ca9aa2bf
TC
830 $$rindex >= 0 && $$rindex < @$images
831 or return '** imgmove can only be used in image iterator **';
832
8b0b2f34
TC
833 my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
834 $img_prefix = '' unless defined $img_prefix;
835 $urladd = '' unless defined $urladd;
836
41f10371 837 my $urlbase = admin_base_url($req->cfg);
cc9019d1
TC
838 my $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
839 my $t = $req->cgi->param('_t');
840 if ($t && $t =~ /^\w+$/) {
841 $url .= "&_t=$t";
842 }
843 $url .= $urladd;
8b0b2f34 844
ca9aa2bf 845 my $image = $images->[$$rindex];
aa6896b6
TC
846 my $csrfp = $req->get_csrf_token("admin_move_image");
847 my $baseurl = "$ENV{SCRIPT_NAME}?id=$article->{id}&imageid=$image->{id}&";
848 $baseurl .= "_csrfp=$csrfp&";
849 my $down_url = "";
ca9aa2bf 850 if ($$rindex < $#$images) {
aa6896b6 851 $down_url = $baseurl . "moveimgdown=1";
ca9aa2bf 852 }
aa6896b6 853 my $up_url = "";
d09682dd 854 if ($$rindex > 0) {
aa6896b6 855 $up_url = $baseurl . "moveimgup=1";
ca9aa2bf 856 }
d09682dd 857 return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
ca9aa2bf
TC
858}
859
860sub tag_movefiles {
8b0b2f34
TC
861 my ($self, $req, $article, $files, $rindex, $arg,
862 $acts, $funcname, $templater) = @_;
abf5bbc6
TC
863
864 $req->user_can('edit_files_reorder', $article)
865 or return '';
ca9aa2bf 866
aefcabcb
TC
867 @$files > 1 or return '';
868
8b0b2f34
TC
869 my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
870 $img_prefix = '' unless defined $img_prefix;
871 $urladd = '' unless defined $urladd;
872
ca9aa2bf
TC
873 $$rindex >= 0 && $$rindex < @$files
874 or return '** movefiles can only be used in the files iterator **';
875
41f10371 876 my $urlbase = admin_base_url($req->cfg);
9063386f
TC
877 my $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}$urladd";
878 my $t = $req->cgi->param('_t');
879 if ($t && $t =~ /^\w+$/) {
880 $url .= "&_t=$t";
881 }
d09682dd
TC
882
883 my $down_url = "";
aa6896b6
TC
884 my $csrfp = $req->get_csrf_token("admin_move_file");
885 my $baseurl = "$ENV{SCRIPT_NAME}?fileswap=1&id=$article->{id}&";
886 $baseurl .= "_csrfp=$csrfp&";
ca9aa2bf 887 if ($$rindex < $#$files) {
aa6896b6 888 $down_url = $baseurl . "file1=$files->[$$rindex]{id}&file2=$files->[$$rindex+1]{id}";
ca9aa2bf 889 }
d09682dd 890 my $up_url = "";
ca9aa2bf 891 if ($$rindex > 0) {
aa6896b6 892 $up_url = $baseurl . "file1=$files->[$$rindex]{id}&file2=$files->[$$rindex-1]{id}";
ca9aa2bf 893 }
d09682dd
TC
894
895 return make_arrows($req->cfg, $down_url, $up_url, $url, $img_prefix);
ca9aa2bf
TC
896}
897
898sub tag_old {
899 my ($article, $cgi, $args, $acts, $funcname, $templater) = @_;
900
901 my ($col, $func, $funcargs) = split ' ', $args, 3;
902 my $value = $cgi->param($col);
903 if (defined $value) {
77804754 904 return escape_html($value);
ca9aa2bf
TC
905 }
906 else {
907 if ($func) {
908 return $templater->perform($acts, $func, $funcargs);
909 }
910 else {
911 $value = $article->{$args};
912 defined $value or $value = '';
77804754 913 return escape_html($value);
ca9aa2bf
TC
914 }
915 }
916}
917
08123550
TC
918sub iter_admin_users {
919 require BSE::TB::AdminUsers;
920
921 BSE::TB::AdminUsers->all;
922}
923
924sub iter_admin_groups {
925 require BSE::TB::AdminGroups;
926
927 BSE::TB::AdminGroups->all;
928}
929
9168c88c
TC
930sub tag_if_field_perm {
931 my ($req, $article, $field) = @_;
932
abf5bbc6
TC
933 unless ($field =~ /^\w+$/) {
934 print STDERR "Bad fieldname '$field'\n";
935 return;
936 }
9168c88c 937 if ($article->{id}) {
abf5bbc6 938 return $req->user_can("edit_field_edit_$field", $article);
9168c88c
TC
939 }
940 else {
4010d92e 941 #print STDERR "adding, always successful\n";
abf5bbc6 942 return 1;
9168c88c
TC
943 }
944}
945
946sub tag_default {
947 my ($self, $req, $article, $args, $acts, $funcname, $templater) = @_;
948
949 my ($col, $func, $funcargs) = split ' ', $args, 3;
950 if ($article->{id}) {
951 if ($func) {
952 return $templater->perform($acts, $func, $funcargs);
953 }
954 else {
955 my $value = $article->{$args};
956 defined $value or $value = '';
b1d01e52 957 return escape_html($value, '<>&"');
9168c88c
TC
958 }
959 }
960 else {
961 my $value = $self->default_value($req, $article, $col);
0ec4ac8a 962 defined $value or $value = '';
b1d01e52 963 return escape_html($value, '<>&"');
9168c88c
TC
964 }
965}
966
918735d1
TC
967sub iter_flags {
968 my ($self) = @_;
969
970 $self->flags;
971}
972
973sub tag_if_flag_set {
974 my ($article, $arg, $acts, $funcname, $templater) = @_;
975
976 my @args = DevHelp::Tags->get_parms($arg, $acts, $templater);
977 @args or return;
978
979 return index($article->{flags}, $args[0]) >= 0;
980}
981
8b0b2f34
TC
982sub iter_crumbs {
983 my ($article, $articles) = @_;
984
985 my @crumbs;
986 my $temp = $article;
987 defined($temp->{parentid}) or return;
988 while ($temp->{parentid} > 0
989 and my $crumb = $articles->getByPkey($temp->{parentid})) {
990 unshift @crumbs, $crumb;
991 $temp = $crumb;
992 }
993
994 @crumbs;
995}
996
997sub tag_typename {
998 my ($args, $acts, $funcname, $templater) = @_;
999
1000 exists $acts->{$args} or return "** need an article name **";
1001 my $generator = $templater->perform($acts, $args, 'generator');
1002
1003 $generator =~ /^(?:BSE::)?Generate::(\w+)$/
1004 or return "** invalid generator $generator **";
1005
1006 return $1;
1007}
1008
ab2cd916
TC
1009sub _get_thumbs_class {
1010 my ($self) = @_;
1011
1012 $self->{cfg}->entry('editor', 'allow_thumb', 0)
1013 or return;
1014
1015 my $class = $self->{cfg}->entry('editor', 'thumbs_class')
1016 or return;
1017
1018 (my $filename = "$class.pm") =~ s!::!/!g;
1019 eval { require $filename; };
1020 if ($@) {
1021 print STDERR "** Error loading thumbs_class $class ($filename): $@\n";
1022 return;
1023 }
1024 my $obj;
1025 eval { $obj = $class->new($self->{cfg}) };
1026 if ($@) {
1027 print STDERR "** Error creating thumbs objects $class: $@\n";
1028 return;
1029 }
1030
1031 return $obj;
1032}
1033
1034sub tag_thumbimage {
1035 my ($cfg, $thumbs_obj, $current_image, $args) = @_;
1036
6a8a6ac5
TC
1037 $thumbs_obj or return '';
1038
ab2cd916
TC
1039 $$current_image or return '** no current image **';
1040
1041 my $imagedir = cfg_image_dir($cfg);
1042
1043 my $filename = "$imagedir/$$current_image->{image}";
1044 -e $filename or return "** image file missing **";
1045
f40af7e2
TC
1046 defined $args && $args =~ /\S/
1047 or $args = "editor";
ab2cd916 1048
195977cd 1049 my $image = $$current_image;
f40af7e2
TC
1050 return $image->thumb
1051 (
1052 geo => $args,
1053 cfg => $cfg,
1054 );
1055}
ab2cd916 1056
8aa7eb30
TC
1057sub tag_file_display {
1058 my ($self, $files, $file_index) = @_;
1059
1060 $$file_index >= 0 && $$file_index < @$files
1061 or return "* file_display only usable inside a files iterator *";
1062 my $file = $files->[$$file_index];
1063
1064 my $disp_type = $self->cfg->entry("editor", "file_display", "");
1065
1066 return $file->inline
1067 (
1068 cfg => $self->cfg,
1069 field => $disp_type,
1070 );
1071}
1072
f40af7e2
TC
1073sub tag_image {
1074 my ($self, $cfg, $rcurrent, $args) = @_;
ab2cd916 1075
f40af7e2
TC
1076 my $im = $$rcurrent
1077 or return '';
195977cd 1078
f40af7e2
TC
1079 my ($align, $rest) = split ' ', $args, 2;
1080
1081 if ($align && exists $im->{$align}) {
1082 if ($align eq 'src') {
1083 return escape_html($im->image_url($self->{cfg}));
1084 }
1085 else {
1086 return escape_html($im->{$align});
1087 }
1088 }
1089 else {
1090 return $im->formatted
1091 (
1092 cfg => $cfg,
1093 align => $align,
1094 extras => $rest,
1095 );
1096 }
ab2cd916
TC
1097}
1098
ca9aa2bf
TC
1099sub low_edit_tags {
1100 my ($self, $acts, $request, $article, $articles, $msg, $errors) = @_;
1101
1102 my $cgi = $request->cgi;
ab2cd916 1103 my $show_full = $cgi->param('f_showfull');
16ac5598 1104 $msg ||= join "\n", map escape_html($_), $cgi->param('message'), $cgi->param('m');
e63c3728 1105 $msg ||= $request->message($errors);
abf5bbc6
TC
1106 my $parent;
1107 if ($article->{id}) {
1108 if ($article->{parentid} > 0) {
1109 $parent = $article->parent;
1110 }
1111 else {
1112 $parent = { title=>"No parent - this is a section", id=>-1 };
1113 }
1114 }
1115 else {
1116 $parent = { title=>"How did we get here?", id=>0 };
1117 }
62533efa
TC
1118 my $cfg = $self->{cfg};
1119 my $mbcs = $cfg->entry('html', 'mbcs', 0);
1120 my $tag_hash = $mbcs ? \&tag_hash_mbcs : \&tag_hash;
ab2cd916
TC
1121 my $thumbs_obj_real = $self->_get_thumbs_class();
1122 my $thumbs_obj = $show_full ? undef : $thumbs_obj_real;
ca9aa2bf
TC
1123 my @images;
1124 my $image_index;
ab2cd916 1125 my $current_image;
ca9aa2bf
TC
1126 my @children;
1127 my $child_index;
1128 my %stepkids;
ca9aa2bf
TC
1129 my @allkids;
1130 my $allkid_index;
1131 my @possstepkids;
1132 my @stepparents;
1133 my $stepparent_index;
1134 my @stepparent_targs;
1135 my @stepparentpossibles;
1136 my @files;
1137 my $file_index;
c2096d67
TC
1138 my @groups;
1139 my $current_group;
ab2cd916 1140 my $it = BSE::Util::Iterate->new;
ca9aa2bf
TC
1141 return
1142 (
58baa27b 1143 $request->admin_tags,
62533efa 1144 article => [ $tag_hash, $article ],
ca9aa2bf 1145 old => [ \&tag_old, $article, $cgi ],
9168c88c 1146 default => [ \&tag_default, $self, $request, $article ],
ca9aa2bf
TC
1147 articleType => [ \&tag_art_type, $article->{level}, $cfg ],
1148 parentType => [ \&tag_art_type, $article->{level}-1, $cfg ],
918735d1 1149 ifNew => [ \&tag_if_new, $article ],
9168c88c 1150 list => [ \&tag_list, $self, $article, $articles, $cgi, $request ],
ca9aa2bf
TC
1151 script => $ENV{SCRIPT_NAME},
1152 level => $article->{level},
1153 checked => \&tag_checked,
ab2cd916 1154 $it->make_iterator
daee3409 1155 ([ \&iter_get_images, $self, $article ], 'image', 'images', \@images,
ab2cd916 1156 \$image_index, undef, \$current_image),
f40af7e2 1157 image => [ tag_image => $self, $cfg, \$current_image ],
ab2cd916
TC
1158 thumbimage => [ \&tag_thumbimage, $cfg, $thumbs_obj, \$current_image ],
1159 ifThumbs => defined($thumbs_obj),
1160 ifCanThumbs => defined($thumbs_obj_real),
abf5bbc6 1161 imgmove => [ \&tag_imgmove, $request, $article, \$image_index, \@images ],
ca9aa2bf
TC
1162 message => $msg,
1163 DevHelp::Tags->make_iterator2
1164 ([ \&iter_get_kids, $article, $articles ],
1165 'child', 'children', \@children, \$child_index),
1166 ifchildren => \&tag_if_children,
1167 childtype => [ \&tag_art_type, $article->{level}+1, $cfg ],
1168 ifHaveChildType => [ \&tag_if_have_child_type, $article->{level}, $cfg ],
abf5bbc6
TC
1169 movechild => [ \&tag_movechild, $self, $request, $article, \@children,
1170 \$child_index],
ca9aa2bf
TC
1171 is => \&tag_is,
1172 templates => [ \&tag_templates, $self, $article, $cfg, $cgi ],
1173 titleImages => [ \&tag_title_images, $self, $article, $cfg, $cgi ],
1174 editParent => [ \&tag_edit_parent, $article ],
1175 DevHelp::Tags->make_iterator2
1176 ([ \&iter_allkids, $article ], 'kid', 'kids', \@allkids, \$allkid_index),
1177 ifStepKid =>
1178 [ \&tag_if_step_kid, $article, \@allkids, \$allkid_index, \%stepkids ],
1179 stepkid => [ \&tag_step_kid, $article, \@allkids, \$allkid_index,
1180 \%stepkids ],
1181 movestepkid =>
31a26b52
TC
1182 [ \&tag_move_stepkid, $self, $cgi, $request, $article, \@allkids,
1183 \$allkid_index ],
ca9aa2bf 1184 possible_stepkids =>
31a26b52
TC
1185 [ \&tag_possible_stepkids, \%stepkids, $request, $article,
1186 \@possstepkids, $articles, $cgi ],
ca9aa2bf 1187 ifPossibles =>
31a26b52
TC
1188 [ \&tag_if_possible_stepkids, \%stepkids, $request, $article,
1189 \@possstepkids, $articles, $cgi ],
ca9aa2bf
TC
1190 DevHelp::Tags->make_iterator2
1191 ( [ \&iter_get_stepparents, $article ], 'stepparent', 'stepparents',
1192 \@stepparents, \$stepparent_index),
1193 ifStepParents => \&tag_ifStepParents,
1194 stepparent_targ =>
1195 [ \&tag_stepparent_targ, $article, \@stepparent_targs,
1196 \$stepparent_index ],
1197 movestepparent =>
31a26b52 1198 [ \&tag_move_stepparent, $self, $cgi, $request, $article, \@stepparents,
ca9aa2bf
TC
1199 \$stepparent_index ],
1200 ifStepparentPossibles =>
31a26b52
TC
1201 [ \&tag_if_stepparent_possibles, $request, $article, $articles,
1202 \@stepparent_targs, \@stepparentpossibles, ],
ca9aa2bf 1203 stepparent_possibles =>
31a26b52 1204 [ \&tag_stepparent_possibles, $cgi, $request, $article, $articles,
ca9aa2bf
TC
1205 \@stepparent_targs, \@stepparentpossibles, ],
1206 DevHelp::Tags->make_iterator2
9366cd70 1207 ([ iter_files => $self, $article ], 'file', 'files', \@files, \$file_index ),
abf5bbc6
TC
1208 movefiles =>
1209 [ \&tag_movefiles, $self, $request, $article, \@files, \$file_index ],
d745f64f
TC
1210 $it->make
1211 (
1212 code => [ iter_file_metas => $self, \@files, \$file_index ],
1213 plural => "file_metas",
1214 single => "file_meta",
1215 nocache => 1,
1216 ),
8aa7eb30 1217 file_display => [ tag_file_display => $self, \@files, \$file_index ],
08123550
TC
1218 DevHelp::Tags->make_iterator2
1219 (\&iter_admin_users, 'iadminuser', 'adminusers'),
1220 DevHelp::Tags->make_iterator2
1221 (\&iter_admin_groups, 'iadmingroup', 'admingroups'),
f2bf0d11 1222 edit => [ \&tag_edit_link, $cfg, $article ],
62533efa 1223 error => [ $tag_hash, $errors ],
b553afa2 1224 error_img => [ \&tag_error_img, $cfg, $errors ],
9168c88c 1225 ifFieldPerm => [ \&tag_if_field_perm, $request, $article ],
62533efa 1226 parent => [ $tag_hash, $parent ],
918735d1
TC
1227 DevHelp::Tags->make_iterator2
1228 ([ \&iter_flags, $self ], 'flag', 'flags' ),
1229 ifFlagSet => [ \&tag_if_flag_set, $article ],
8b0b2f34
TC
1230 DevHelp::Tags->make_iterator2
1231 ([ \&iter_crumbs, $article, $articles ], 'crumb', 'crumbs' ),
1232 typename => \&tag_typename,
c2096d67
TC
1233 $it->make_iterator([ \&iter_groups, $request ],
1234 'group', 'groups', \@groups, undef, undef,
1235 \$current_group),
e63c3728
TC
1236 $it->make_iterator([ iter_image_stores => $self],
1237 'image_store', 'image_stores'),
1238 $it->make_iterator([ iter_file_stores => $self],
1239 'file_store', 'file_stores'),
c2096d67 1240 ifGroupRequired => [ \&tag_ifGroupRequired, $article, \$current_group ],
ca9aa2bf
TC
1241 );
1242}
1243
e63c3728
TC
1244sub iter_image_stores {
1245 my ($self) = @_;
1246
1247 my $mgr = $self->_image_manager;
1248
1249 return map +{ name => $_->name, description => $_->description },
1250 $mgr->all_stores;
1251}
1252
1253sub _file_manager {
1254 my ($self) = @_;
1255
7646d96e 1256 require BSE::TB::ArticleFiles;
e63c3728 1257
7646d96e 1258 return BSE::TB::ArticleFiles->file_manager($self->cfg);
e63c3728
TC
1259}
1260
1261sub iter_file_stores {
1262 my ($self) = @_;
1263
7646d96e
TC
1264 require BSE::TB::ArticleFiles;
1265 my $mgr = $self->_file_manager($self->cfg);
e63c3728
TC
1266
1267 return map +{ name => $_->name, description => $_->description },
1268 $mgr->all_stores;
1269}
1270
c2096d67
TC
1271sub iter_groups {
1272 my ($req) = @_;
1273
1274 require BSE::TB::SiteUserGroups;
1275 BSE::TB::SiteUserGroups->admin_and_query_groups($req->cfg);
1276}
1277
1278sub tag_ifGroupRequired {
1279 my ($article, $rgroup) = @_;
1280
1281 $$rgroup or return 0;
1282
1283 $article->is_accessible_to($$rgroup);
1284}
1285
ca9aa2bf
TC
1286sub edit_template {
1287 my ($self, $article, $cgi) = @_;
1288
1289 my $base = $article->{level};
1290 my $t = $cgi->param('_t');
1291 if ($t && $t =~ /^\w+$/) {
1292 $base = $t;
1293 }
1294 return $self->{cfg}->entry('admin templates', $base,
1295 "admin/edit_$base");
1296}
1297
1298sub add_template {
1299 my ($self, $article, $cgi) = @_;
1300
1301 $self->edit_template($article, $cgi);
1302}
1303
1304sub low_edit_form {
1305 my ($self, $request, $article, $articles, $msg, $errors) = @_;
1306
1307 my $cgi = $request->cgi;
1308 my %acts;
1309 %acts = $self->low_edit_tags(\%acts, $request, $article, $articles, $msg,
1310 $errors);
1311 my $template = $article->{id} ?
1312 $self->edit_template($article, $cgi) : $self->add_template($article, $cgi);
1313
f2bf0d11 1314 return $request->response($template, \%acts);
ca9aa2bf
TC
1315}
1316
1317sub edit_form {
1318 my ($self, $request, $article, $articles, $msg, $errors) = @_;
1319
1320 return $self->low_edit_form($request, $article, $articles, $msg, $errors);
1321}
1322
aa6896b6
TC
1323sub _dummy_article {
1324 my ($self, $req, $articles, $rmsg) = @_;
ca9aa2bf
TC
1325
1326 my $level;
9168c88c 1327 my $cgi = $req->cgi;
ca9aa2bf
TC
1328 my $parentid = $cgi->param('parentid');
1329 if ($parentid) {
1330 if ($parentid =~ /^\d+$/) {
1331 if (my $parent = $self->get_parent($parentid, $articles)) {
1332 $level = $parent->{level}+1;
1333 }
1334 else {
1335 $parentid = undef;
1336 }
1337 }
1338 elsif ($parentid eq "-1") {
1339 $level = 1;
1340 }
1341 }
1342 unless (defined $level) {
1343 $level = $cgi->param('level');
1344 undef $level unless defined $level && $level =~ /^\d+$/
1345 && $level > 0 && $level < 100;
1346 defined $level or $level = 3;
1347 }
1348
1349 my %article;
1350 my @cols = Article->columns;
1351 @article{@cols} = ('') x @cols;
1352 $article{id} = '';
1353 $article{parentid} = $parentid;
1354 $article{level} = $level;
1355 $article{body} = '<maximum of 64Kb>';
1356 $article{listed} = 1;
1357 $article{generator} = $self->generator;
1358
9168c88c 1359 my ($values, $labels) = $self->possible_parents(\%article, $articles, $req);
1b02d672 1360 unless (@$values) {
aa6896b6
TC
1361 $$rmsg = "You can't add children to any article at that level";
1362 return;
1363 }
1364
1365 return \%article;
1366}
1367
1368sub add_form {
1369 my ($self, $req, $articles, $msg, $errors) = @_;
1370
1371 my $mymsg;
1372 my $article = $self->_dummy_article($req, $articles, \$mymsg);
1373 unless ($article) {
1b02d672
TC
1374 require BSE::Edit::Site;
1375 my $site = BSE::Edit::Site->new(cfg=>$req->cfg, db=> BSE::DB->single);
aa6896b6 1376 return $site->edit_sections($req, $articles, $mymsg);
1b02d672 1377 }
9168c88c 1378
aa6896b6 1379 return $self->low_edit_form($req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
1380}
1381
1382sub generator { 'Generate::Article' }
1383
331fd099
TC
1384sub typename {
1385 my ($self) = @_;
1386
1387 my $gen = $self->generator;
1388
1389 ($gen =~ /(\w+)$/)[0] || 'Article';
1390}
1391
ca9aa2bf 1392sub _validate_common {
b553afa2 1393 my ($self, $data, $articles, $errors, $article) = @_;
ca9aa2bf 1394
918735d1
TC
1395# if (defined $data->{parentid} && $data->{parentid} =~ /^(?:-1|\d+)$/) {
1396# unless ($data->{parentid} == -1 or
1397# $articles->getByPkey($data->{parentid})) {
1398# $errors->{parentid} = "Selected parent article doesn't exist";
1399# }
1400# }
1401# else {
1402# $errors->{parentid} = "You need to select a valid parent";
1403# }
1404 if (exists $data->{title} && $data->{title} !~ /\S/) {
1405 $errors->{title} = "Please enter a title";
ca9aa2bf
TC
1406 }
1407
1408 if (exists $data->{template} && $data->{template} =~ /\.\./) {
1409 $errors->{template} = "Please only select templates from the list provided";
1410 }
c76e86ea
TC
1411 if (exists $data->{linkAlias}
1412 && length $data->{linkAlias}) {
90ee1626 1413 unless ($data->{linkAlias} =~ /\A[a-zA-Z0-9-_]+\z/
c76e86ea
TC
1414 && $data->{linkAlias} =~ /[A-Za-z]/) {
1415 $errors->{linkAlias} = "Link alias must contain only alphanumerics and contain at least one letter";
1416 }
1417 }
ca9aa2bf
TC
1418}
1419
1420sub validate {
918735d1 1421 my ($self, $data, $articles, $errors) = @_;
ca9aa2bf
TC
1422
1423 $self->_validate_common($data, $articles, $errors);
c76e86ea
TC
1424 if (!$errors->{linkAlias} && defined $data->{linkAlias} && length $data->{linkAlias}) {
1425 my $other = $articles->getBy(linkAlias => $data->{linkAlias});
1426 $other
1427 and $errors->{linkAlias} =
1428 "Duplicate link alias - already used by article $other->{id}";
1429 }
331fd099
TC
1430 custom_class($self->{cfg})
1431 ->article_validate($data, undef, $self->typename, $errors);
ca9aa2bf
TC
1432
1433 return !keys %$errors;
1434}
1435
1436sub validate_old {
918735d1 1437 my ($self, $article, $data, $articles, $errors) = @_;
ca9aa2bf 1438
b553afa2 1439 $self->_validate_common($data, $articles, $errors, $article);
331fd099
TC
1440 custom_class($self->{cfg})
1441 ->article_validate($data, $article, $self->typename, $errors);
ca9aa2bf 1442
b553afa2
TC
1443 if (exists $data->{release} && !valid_date($data->{release})) {
1444 $errors->{release} = "Invalid release date";
1445 }
1446
c76e86ea
TC
1447 if (!$errors->{linkAlias}
1448 && defined $data->{linkAlias}
1449 && length $data->{linkAlias}
1450 && $data->{linkAlias} ne $article->{linkAlias}) {
1451 my $other = $articles->getBy(linkAlias => $data->{linkAlias});
90ee1626 1452 $other && $other->{id} != $article->{id}
c76e86ea
TC
1453 and $errors->{linkAlias} = "Duplicate link alias - already used by article $other->{id}";
1454 }
1455
ca9aa2bf
TC
1456 return !keys %$errors;
1457}
1458
1459sub validate_parent {
1460 1;
1461}
1462
1463sub fill_new_data {
1464 my ($self, $req, $data, $articles) = @_;
1465
331fd099
TC
1466 custom_class($self->{cfg})
1467 ->article_fill_new($data, $self->typename);
1468
ca9aa2bf
TC
1469 1;
1470}
1471
95989433
TC
1472sub link_path {
1473 my ($self, $article) = @_;
1474
1475 # check the config for the article and any of its ancestors
1476 my $work_article = $article;
1477 my $path = $self->{cfg}->entry('article uris', $work_article->{id});
1478 while (!$path) {
1479 last if $work_article->{parentid} == -1;
1480 $work_article = $work_article->parent;
1481 $path = $self->{cfg}->entry('article uris', $work_article->{id});
1482 }
1483 return $path if $path;
1484
1485 $self->default_link_path($article);
1486}
1487
1488sub default_link_path {
1489 my ($self, $article) = @_;
1490
1491 $self->{cfg}->entry('uri', 'articles', '/a');
1492}
1493
ca9aa2bf
TC
1494sub make_link {
1495 my ($self, $article) = @_;
1496
efcc5a30 1497 if ($article->is_dynamic) {
b873a8fa 1498 return "/cgi-bin/page.pl?page=$article->{id}&title=".escape_uri($article->{title});
efcc5a30
TC
1499 }
1500
95989433 1501 my $article_uri = $self->link_path($article);
ca9aa2bf
TC
1502 my $link = "$article_uri/$article->{id}.html";
1503 my $link_titles = $self->{cfg}->entryBool('basic', 'link_titles', 0);
1504 if ($link_titles) {
1505 (my $extra = lc $article->{title}) =~ tr/a-z0-9/_/sc;
d7538448 1506 $link .= "/" . $extra . "_html";
ca9aa2bf
TC
1507 }
1508
1509 $link;
1510}
1511
1512sub save_new {
1513 my ($self, $req, $articles) = @_;
aa6896b6
TC
1514
1515 $req->check_csrf("admin_add_article")
1516 or return $self->csrf_error($req, undef, "admin_add_article", "Add Article");
ca9aa2bf
TC
1517
1518 my $cgi = $req->cgi;
1519 my %data;
1520 my $table_object = $self->table_object($articles);
1521 my @columns = $table_object->rowClass->columns;
1522 $self->save_thumbnail($cgi, undef, \%data);
1523 for my $name (@columns) {
9168c88c
TC
1524 $data{$name} = $cgi->param($name)
1525 if defined $cgi->param($name);
ca9aa2bf 1526 }
918735d1 1527 $data{flags} = join '', sort $cgi->param('flags');
ca9aa2bf
TC
1528
1529 my $msg;
1530 my %errors;
718a070d
TC
1531 if (!defined $data{parentid} || $data{parentid} eq '') {
1532 $errors{parentid} = "Please select a parent";
1533 }
1534 elsif ($data{parentid} !~ /^(?:-1|\d+)$/) {
1535 $errors{parentid} = "Invalid parent selection (template bug)";
1536 }
918735d1 1537 $self->validate(\%data, $articles, \%errors)
ca9aa2bf
TC
1538 or return $self->add_form($req, $articles, $msg, \%errors);
1539
1540 my $parent;
1541 if ($data{parentid} > 0) {
1542 $parent = $articles->getByPkey($data{parentid}) or die;
9168c88c
TC
1543 $req->user_can('edit_add_child', $parent)
1544 or return $self->add_form($req, $articles,
1545 "You cannot add a child to that article");
1546 for my $name (@columns) {
1547 if (exists $data{$name} &&
1548 !$req->user_can("edit_add_field_$name", $parent)) {
1549 delete $data{$name};
1550 }
1551 }
ca9aa2bf 1552 }
9168c88c
TC
1553 else {
1554 $req->user_can('edit_add_child')
1555 or return $self->add_form($req, $articles,
1556 "You cannot create a top-level article");
1557 for my $name (@columns) {
1558 if (exists $data{$name} &&
1559 !$req->user_can("edit_add_field_$name")) {
1560 delete $data{$name};
1561 }
1562 }
1563 }
1564
ca9aa2bf
TC
1565 $self->validate_parent(\%data, $articles, $parent, \$msg)
1566 or return $self->add_form($req, $articles, $msg);
1567
ca9aa2bf 1568 my $level = $parent ? $parent->{level}+1 : 1;
0ec4ac8a 1569 $data{level} = $level;
9168c88c 1570 $data{displayOrder} = time;
ca9aa2bf
TC
1571 $data{link} ||= '';
1572 $data{admin} ||= '';
ca9aa2bf 1573 $data{generator} = $self->generator;
41f10371 1574 $data{lastModified} = now_sqldatetime();
ca9aa2bf
TC
1575 $data{listed} = 1 unless defined $data{listed};
1576
9604a90c
TC
1577# Added by adrian
1578 $data{pageTitle} = '' unless defined $data{pageTitle};
1579 my $user = $req->getuser;
1580 $data{createdBy} = $user ? $user->{logon} : '';
1581 $data{lastModifiedBy} = $user ? $user->{logon} : '';
1582 $data{created} = now_sqldatetime();
12bcb7ac
TC
1583# end adrian
1584
efcc5a30
TC
1585 $data{force_dynamic} = 0;
1586 $data{cached_dynamic} = 0;
1587 $data{inherit_siteuser_rights} = 1;
9604a90c 1588
12bcb7ac
TC
1589# Added by adrian
1590 $data{metaDescription} = '' unless defined $data{metaDescription};
1591 $data{metaKeywords} = '' unless defined $data{metaKeywords};
1592# end adrian
1593
0ec4ac8a 1594 $self->fill_new_data($req, \%data, $articles);
c76e86ea 1595 for my $col (qw(titleImage imagePos template keyword menu titleAlias linkAlias)) {
0ec4ac8a
TC
1596 defined $data{$col}
1597 or $data{$col} = $self->default_value($req, \%data, $col);
1598 }
1599
c2096d67
TC
1600 for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1601 if ($req->user_can("edit_add_field_$col", $parent)
1602 && $cgi->param("save_$col")) {
1603 $data{$col} = $cgi->param($col) ? 1 : 0;
1604 }
1605 else {
1606 $data{$col} = $self->default_value($req, \%data, $col);
1607 }
1608 }
1609
718a070d
TC
1610 for my $col (qw(release expire)) {
1611 $data{$col} = sql_date($data{$col});
1612 }
1613
0ec4ac8a 1614 # these columns are handled a little differently
d7538448 1615 for my $col (qw(release expire threshold summaryLength )) {
0ec4ac8a
TC
1616 $data{$col}
1617 or $data{$col} = $self->default_value($req, \%data, $col);
1618 }
1619
ca9aa2bf
TC
1620 shift @columns;
1621 my $article = $table_object->add(@data{@columns});
1622
1623 # we now have an id - generate the links
1624
a319d280 1625 $article->update_dynamic($self->{cfg});
ca9aa2bf
TC
1626 my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
1627 $article->setAdmin("$cgi_uri/admin/admin.pl?id=$article->{id}");
1628 $article->setLink($self->make_link($article));
1629 $article->save();
1630
caa7299c
TC
1631 use Util 'generate_article';
1632 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
1633
8b0b2f34
TC
1634 my $r = $cgi->param('r');
1635 if ($r) {
1636 $r .= ($r =~ /\?/) ? '&' : '?';
1637 $r .= "id=$article->{id}";
1638 }
1639 else {
41f10371
TC
1640
1641 $r = admin_base_url($req->cfg) . $article->{admin};
8b0b2f34
TC
1642 }
1643 return BSE::Template->get_refresh($r, $self->{cfg});
1644
ca9aa2bf
TC
1645}
1646
1647sub fill_old_data {
0d5ccc7f 1648 my ($self, $req, $article, $data) = @_;
ca9aa2bf 1649
4010d92e
TC
1650 if (exists $data->{body}) {
1651 $data->{body} =~ s/\x0D\x0A/\n/g;
1652 $data->{body} =~ tr/\r/\n/;
1653 }
ca9aa2bf 1654 for my $col (Article->columns) {
331fd099 1655 next if $col =~ /^custom/;
ca9aa2bf
TC
1656 $article->{$col} = $data->{$col}
1657 if exists $data->{$col} && $col ne 'id' && $col ne 'parentid';
1658 }
331fd099
TC
1659 custom_class($self->{cfg})
1660 ->article_fill_old($article, $data, $self->typename);
ca9aa2bf
TC
1661
1662 return 1;
1663}
1664
1665sub save {
1666 my ($self, $req, $article, $articles) = @_;
4010d92e 1667
aa6896b6
TC
1668 $req->check_csrf("admin_save_article")
1669 or return $self->csrf_error($req, $article, "admin_save_article", "Save Article");
1670
4010d92e
TC
1671 $req->user_can(edit_save => $article)
1672 or return $self->edit_form($req, $article, $articles,
1673 "You don't have access to save this article");
efcc5a30
TC
1674
1675 my $old_dynamic = $article->is_dynamic;
ca9aa2bf
TC
1676 my $cgi = $req->cgi;
1677 my %data;
1678 for my $name ($article->columns) {
1679 $data{$name} = $cgi->param($name)
abf5bbc6
TC
1680 if defined($cgi->param($name)) and $name ne 'id' && $name ne 'parentid'
1681 && $req->user_can("edit_field_edit_$name", $article);
ca9aa2bf 1682 }
12b42a0b
TC
1683
1684# Added by adrian
1685# checks editor lastModified against record lastModified
1686 if ($self->{cfg}->entry('editor', 'check_modified')) {
1687 if ($article->{lastModified} ne $cgi->param('lastModified')) {
1688 my $whoModified = '';
1689 my $timeModified = ampm_time($article->{lastModified});
1690 if ($article->{lastModifiedBy}) {
1691 $whoModified = "by '$article->{lastModifiedBy}'";
1692 }
1693 print STDERR "non-matching lastModified, article not saved\n";
1694 my $msg = "Article changes not saved, this article was modified $whoModified at $timeModified since this editor was loaded";
1695 return $self->edit_form($req, $article, $articles, $msg);
1696 }
1697 }
1698# end adrian
1699
918735d1
TC
1700 # possibly this needs tighter error checking
1701 $data{flags} = join '', sort $cgi->param('flags')
1702 if $req->user_can("edit_field_edit_flags", $article);
ca9aa2bf
TC
1703 my %errors;
1704 $self->validate_old($article, \%data, $articles, \%errors)
1705 or return $self->edit_form($req, $article, $articles, undef, \%errors);
abf5bbc6
TC
1706 $self->save_thumbnail($cgi, $article, \%data)
1707 if $req->user_can('edit_field_edit_thumbImage', $article);
ca9aa2bf
TC
1708 $self->fill_old_data($req, $article, \%data);
1709 if (exists $article->{template} &&
1710 $article->{template} =~ m|\.\.|) {
1711 my $msg = "Please only select templates from the list provided";
1712 return $self->edit_form($req, $article, $articles, $msg);
1713 }
12b42a0b 1714
ca9aa2bf
TC
1715 # reparenting
1716 my $newparentid = $cgi->param('parentid');
abf5bbc6
TC
1717 if ($newparentid && $req->user_can('edit_field_edit_parentid', $article)) {
1718 if ($newparentid == $article->{parentid}) {
1719 # nothing to do
1720 }
1721 elsif ($newparentid != -1) {
1722 print STDERR "Reparenting...\n";
1723 my $newparent = $articles->getByPkey($newparentid);
1724 if ($newparent) {
1725 if ($newparent->{level} != $article->{level}-1) {
1726 # the article cannot become a child of itself or one of it's
1727 # children
1728 if ($article->{id} == $newparentid
1729 || $self->is_descendant($article->{id}, $newparentid, $articles)) {
1730 my $msg = "Cannot become a child of itself or of a descendant";
1731 return $self->edit_form($req, $article, $articles, $msg);
1732 }
1733 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
1734 if ($self->is_descendant($article->{id}, $shopid, $articles)) {
1735 my $msg = "Cannot become a descendant of the shop";
1736 return $self->edit_form($req, $article, $articles, $msg);
1737 }
1738 my $msg;
1739 $self->reparent($article, $newparentid, $articles, \$msg)
1740 or return $self->edit_form($req, $article, $articles, $msg);
ca9aa2bf 1741 }
abf5bbc6
TC
1742 else {
1743 # stays at the same level, nothing special
1744 $article->{parentid} = $newparentid;
ca9aa2bf 1745 }
ca9aa2bf 1746 }
abf5bbc6
TC
1747 # else ignore it
1748 }
1749 else {
1750 # becoming a section
1751 my $msg;
1752 $self->reparent($article, -1, $articles, \$msg)
1753 or return $self->edit_form($req, $article, $articles, $msg);
ca9aa2bf 1754 }
ca9aa2bf
TC
1755 }
1756
abf5bbc6 1757 $article->{listed} = $cgi->param('listed')
63e99d77 1758 if defined $cgi->param('listed') &&
abf5bbc6
TC
1759 $req->user_can('edit_field_edit_listed', $article);
1760 $article->{release} = sql_date($cgi->param('release'))
1761 if defined $cgi->param('release') &&
1762 $req->user_can('edit_field_edit_release', $article);
1763
1764 $article->{expire} = sql_date($cgi->param('expire')) || $Constants::D_99
1765 if defined $cgi->param('expire') &&
1766 $req->user_can('edit_field_edit_expire', $article);
41f10371 1767 $article->{lastModified} = now_sqldatetime();
c2096d67
TC
1768 for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1769 if ($req->user_can("edit_field_edit_$col", $article)
1770 && $cgi->param("save_$col")) {
1771 $article->{$col} = $cgi->param($col) ? 1 : 0;
1772 }
1773 }
1774
1775# Added by adrian
1776 my $user = $req->getuser;
1777 $article->{lastModifiedBy} = $user ? $user->{logon} : '';
1778# end adrian
1779
1780 my @save_group_ids = $cgi->param('save_group_id');
1781 if ($req->user_can('edit_field_edit_group_id')
1782 && @save_group_ids) {
1783 require BSE::TB::SiteUserGroups;
1784 my %groups = map { $_->{id} => $_ }
1785 BSE::TB::SiteUserGroups->admin_and_query_groups($self->{cfg});
1786 my %set = map { $_ => 1 } $cgi->param('group_id');
1787 my %current = map { $_ => 1 } $article->group_ids;
1788
1789 for my $group_id (@save_group_ids) {
1790 $groups{$group_id} or next;
1791 if ($current{$group_id} && !$set{$group_id}) {
1792 $article->remove_group_id($group_id);
1793 }
1794 elsif (!$current{$group_id} && $set{$group_id}) {
1795 $article->add_group_id($group_id);
1796 }
1797 }
efcc5a30
TC
1798 }
1799
63e99d77 1800 my $old_link = $article->{link};
efcc5a30
TC
1801 # this need to go last
1802 $article->update_dynamic($self->{cfg});
95989433
TC
1803 if ($article->{link} &&
1804 !$self->{cfg}->entry('protect link', $article->{id})) {
1805 my $article_uri = $self->make_link($article);
95989433 1806 $article->setLink($article_uri);
ca9aa2bf
TC
1807 }
1808
1809 $article->save();
caa7299c 1810
63e99d77 1811 # fix the kids too
efcc5a30 1812 my @extra_regen;
63e99d77
TC
1813 @extra_regen = $self->update_child_dynamic($article, $articles, $req);
1814
1815 if ($article->is_dynamic || $old_dynamic) {
1816 if (!$old_dynamic and $old_link) {
1817 unlink $article->link_to_filename($self->{cfg}, $old_link);
1818 }
16901a2a
TC
1819 elsif (!$article->is_dynamic) {
1820 unlink $article->cached_filename($self->{cfg});
1821 }
efcc5a30
TC
1822 }
1823
caa7299c 1824 use Util 'generate_article';
efcc5a30
TC
1825 if ($Constants::AUTO_GENERATE) {
1826 generate_article($articles, $article);
1827 for my $regen_id (@extra_regen) {
1828 my $regen = $articles->getByPkey($regen_id);
63e99d77 1829 Util::generate_low($articles, $regen, $self->{cfg});
efcc5a30
TC
1830 }
1831 }
caa7299c 1832
8b0b2f34 1833 return $self->refresh($article, $cgi, undef, 'Article saved');
ca9aa2bf
TC
1834}
1835
efcc5a30
TC
1836sub update_child_dynamic {
1837 my ($self, $article, $articles, $req) = @_;
1838
1839 my $cfg = $req->cfg;
1840 my @stack = $article->children;
1841 my @regen;
1842 while (@stack) {
1843 my $workart = pop @stack;
1844 my $old_dynamic = $workart->is_dynamic; # before update
63e99d77 1845 my $old_link = $workart->{link};
3e37b5ba
TC
1846 my $editor;
1847 ($editor, $workart) = $self->article_class($workart, $articles, $cfg);
1848
efcc5a30
TC
1849 $workart->update_dynamic($cfg);
1850 if ($old_dynamic != $workart->is_dynamic) {
1851 # update the link
1852 if ($article->{link} && !$cfg->entry('protect link', $workart->{id})) {
efcc5a30
TC
1853 my $uri = $editor->make_link($workart);
1854 $workart->setLink($uri);
63e99d77 1855
8f84f3f1
TC
1856 !$old_dynamic && $old_link
1857 and unlink $workart->link_to_filename($cfg, $old_link);
1858 $workart->is_dynamic
16901a2a 1859 or unlink $workart->cached_filename($cfg);
efcc5a30
TC
1860 }
1861
1862 # save dynamic cache change and link if that changed
1863 $workart->save;
1864 }
1865 push @stack, $workart->children;
1866 push @regen, $workart->{id};
1867 }
1868
1869 @regen;
1870}
1871
ca9aa2bf
TC
1872sub sql_date {
1873 my $str = shift;
1874 my ($year, $month, $day);
1875
1876 # look for a date
1877 if (($day, $month, $year) = ($str =~ m!(\d+)/(\d+)/(\d+)!)) {
1878 $year += 2000 if $year < 100;
1879
1880 return sprintf("%04d-%02d-%02d", $year, $month, $day);
1881 }
1882 return undef;
1883}
1884
12b42a0b
TC
1885# Added by adrian
1886# Converts 24hr time to 12hr AM/PM time
1887sub ampm_time {
1888 my $str = shift;
1889 my ($hour, $minute, $second, $ampm);
1890
1891 # look for a time
1892 if (($hour, $minute, $second) = ($str =~ m!(\d+):(\d+):(\d+)!)) {
1893 if ($hour > 12) {
1894 $hour -= 12;
1895 $ampm = 'PM';
1896 }
1897 else {
c2096d67 1898 $hour = 12 if $hour == 0;
12b42a0b
TC
1899 $ampm = 'AM';
1900 }
1901 return sprintf("%02d:%02d:%02d $ampm", $hour, $minute, $second);
1902 }
1903 return undef;
1904}
1905# end adrian
1906
ca9aa2bf
TC
1907sub reparent {
1908 my ($self, $article, $newparentid, $articles, $rmsg) = @_;
1909
1910 my $newlevel;
1911 if ($newparentid == -1) {
1912 $newlevel = 1;
1913 }
1914 else {
1915 my $parent = $articles->getByPkey($newparentid);
1916 unless ($parent) {
1917 $$rmsg = "Cannot get new parent article";
1918 return;
1919 }
1920 $newlevel = $parent->{level} + 1;
1921 }
1922 # the caller will save this one
1923 $article->{parentid} = $newparentid;
1924 $article->{level} = $newlevel;
1925 $article->{displayOrder} = time;
1926
1927 my @change = ( [ $article->{id}, $newlevel ] );
1928 while (@change) {
1929 my $this = shift @change;
1930 my ($art, $level) = @$this;
1931
1932 my @kids = $articles->getBy(parentid=>$art);
1933 push @change, map { [ $_->{id}, $level+1 ] } @kids;
1934
1935 for my $kid (@kids) {
1936 $kid->{level} = $level+1;
1937 $kid->save;
1938 }
1939 }
1940
1941 return 1;
1942}
1943
1944# tests if $desc is a descendant of $art
1945# where both are article ids
1946sub is_descendant {
1947 my ($self, $art, $desc, $articles) = @_;
1948
1949 my @check = ($art);
1950 while (@check) {
1951 my $parent = shift @check;
1952 $parent == $desc and return 1;
1953 my @kids = $articles->getBy(parentid=>$parent);
1954 push @check, map $_->{id}, @kids;
1955 }
1956
1957 return 0;
1958}
1959
1960sub save_thumbnail {
1961 my ($self, $cgi, $original, $newdata) = @_;
1962
1963 unless ($original) {
1964 @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
1965 }
ab2cd916 1966 my $imagedir = cfg_image_dir($self->{cfg});
ca9aa2bf
TC
1967 if ($cgi->param('remove_thumb') && $original && $original->{thumbImage}) {
1968 unlink("$imagedir/$original->{thumbImage}");
1969 @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
1970 }
1971 my $image = $cgi->param('thumbnail');
1972 if ($image && -s $image) {
1973 # where to put it...
1974 my $name = '';
1975 $image =~ /([\w.-]+)$/ and $name = $1;
1976 my $filename = time . "_" . $name;
1977
1978 use Fcntl;
1979 my $counter = "";
1980 $filename = time . '_' . $counter . '_' . $name
1981 until sysopen( OUTPUT, "$imagedir/$filename",
1982 O_WRONLY| O_CREAT| O_EXCL)
1983 || ++$counter > 100;
1984
1985 fileno(OUTPUT) or die "Could not open image file: $!";
1986 binmode OUTPUT;
1987 my $buffer;
1988
1989 #no strict 'refs';
1990
1991 # read the image in from the browser and output it to our
1992 # output filehandle
1993 print STDERR "\$image ",ref $image,"\n";
1994 seek $image, 0, 0;
1995 print OUTPUT $buffer while sysread $image, $buffer, 1024;
1996
1997 close OUTPUT
1998 or die "Could not close image output file: $!";
1999
2000 use Image::Size;
2001
2002 if ($original && $original->{thumbImage}) {
2003 #unlink("$imagedir/$original->{thumbImage}");
2004 }
2005 @$newdata{qw/thumbWidth thumbHeight/} = imgsize("$imagedir/$filename");
2006 $newdata->{thumbImage} = $filename;
2007 }
2008}
2009
2010sub child_types {
2011 my ($self, $article) = @_;
2012
2013 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2014 if ($article && $article->{id} && $article->{id} == $shopid) {
2015 return ( 'BSE::Edit::Catalog' );
2016 }
2017 return ( 'BSE::Edit::Article' );
2018}
2019
2020sub add_stepkid {
2021 my ($self, $req, $article, $articles) = @_;
2022
aa6896b6
TC
2023 $req->check_csrf("admin_add_stepkid")
2024 or return $self->csrf_error($req, $article, "admin_add_stepkid", "Add Stepkid");
2025
31a26b52
TC
2026 $req->user_can(edit_stepkid_add => $article)
2027 or return $self->edit_form($req, $article, $articles,
2028 "You don't have access to add step children to this article");
2029
ca9aa2bf
TC
2030 my $cgi = $req->cgi;
2031 require 'BSE/Admin/StepParents.pm';
2032 eval {
2033 my $childId = $cgi->param('stepkid');
2034 defined $childId
2035 or die "No stepkid supplied to add_stepkid";
2036 $childId =~ /^\d+$/
2037 or die "Invalid stepkid supplied to add_stepkid";
2038 my $child = $articles->getByPkey($childId)
2039 or die "Article $childId not found";
31a26b52
TC
2040
2041 $req->user_can(edit_stepparent_add => $child)
2042 or die "You don't have access to add a stepparent to that article\n";
ca9aa2bf
TC
2043
2044 use BSE::Util::Valid qw/valid_date/;
2045 my $release = $cgi->param('release');
2046 valid_date($release) or $release = undef;
2047 my $expire = $cgi->param('expire');
2048 valid_date($expire) or $expire = undef;
2049
2050 my $newentry =
2051 BSE::Admin::StepParents->add($article, $child, $release, $expire);
2052 };
2053 if ($@) {
2054 return $self->edit_form($req, $article, $articles, $@);
2055 }
a0a8147b
TC
2056
2057 use Util 'generate_article';
2058 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2059
8b0b2f34 2060 return $self->refresh($article, $cgi, 'step', 'Stepchild added');
ca9aa2bf
TC
2061}
2062
2063sub del_stepkid {
2064 my ($self, $req, $article, $articles) = @_;
2065
aa6896b6
TC
2066 $req->check_csrf("admin_remove_stepkid")
2067 or return $self->csrf_error($req, $article, "admin_del_stepkid", "Delete Stepkid");
31a26b52
TC
2068 $req->user_can(edit_stepkid_delete => $article)
2069 or return $self->edit_form($req, $article, $articles,
2070 "You don't have access to delete stepchildren from this article");
2071
ca9aa2bf
TC
2072 my $cgi = $req->cgi;
2073 require 'BSE/Admin/StepParents.pm';
2074 eval {
2075 my $childId = $cgi->param('stepkid');
2076 defined $childId
2077 or die "No stepkid supplied to add_stepkid";
2078 $childId =~ /^\d+$/
2079 or die "Invalid stepkid supplied to add_stepkid";
2080 my $child = $articles->getByPkey($childId)
2081 or die "Article $childId not found";
31a26b52
TC
2082
2083 $req->user_can(edit_stepparent_delete => $child)
2084 or die "You cannot remove stepparents from that article\n";
ca9aa2bf
TC
2085
2086 BSE::Admin::StepParents->del($article, $child);
2087 };
2088
2089 if ($@) {
2090 return $self->edit_form($req, $article, $articles, $@);
2091 }
a0a8147b
TC
2092 use Util 'generate_article';
2093 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2094
8b0b2f34 2095 return $self->refresh($article, $cgi, 'step', 'Stepchild deleted');
ca9aa2bf
TC
2096}
2097
2098sub save_stepkids {
2099 my ($self, $req, $article, $articles) = @_;
2100
aa6896b6
TC
2101 $req->check_csrf("admin_save_stepkids")
2102 or return $self->csrf_error($req, $article, "admin_save_stepkids", "Save Stepkids");
2103
31a26b52
TC
2104 $req->user_can(edit_stepkid_save => $article)
2105 or return $self->edit_form($req, $article, $articles,
2106 "No access to save stepkid data for this article");
2107
ca9aa2bf
TC
2108 my $cgi = $req->cgi;
2109 require 'BSE/Admin/StepParents.pm';
2110 my @stepcats = OtherParents->getBy(parentId=>$article->{id});
2111 my %stepcats = map { $_->{parentId}, $_ } @stepcats;
2112 my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2113 for my $stepcat (@stepcats) {
31a26b52
TC
2114 $req->user_can(edit_stepparent_save => $stepcat->{childId})
2115 or next;
ca9aa2bf
TC
2116 for my $name (qw/release expire/) {
2117 my $date = $cgi->param($name.'_'.$stepcat->{childId});
2118 if (defined $date) {
2119 if ($date eq '') {
2120 $date = $datedefs{$name};
2121 }
2122 elsif (valid_date($date)) {
2123 use BSE::Util::SQL qw/date_to_sql/;
2124 $date = date_to_sql($date);
2125 }
2126 else {
2127 return $self->refresh($article, $cgi, '', "Invalid date '$date'");
2128 }
2129 $stepcat->{$name} = $date;
2130 }
2131 }
2132 eval {
2133 $stepcat->save();
2134 };
2135 $@ and return $self->refresh($article, $cgi, '', $@);
2136 }
a0a8147b
TC
2137 use Util 'generate_article';
2138 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2139
8b0b2f34 2140 return $self->refresh($article, $cgi, 'step', 'Stepchild information saved');
ca9aa2bf
TC
2141}
2142
2143sub add_stepparent {
2144 my ($self, $req, $article, $articles) = @_;
2145
aa6896b6
TC
2146 $req->check_csrf("admin_add_stepparent")
2147 or return $self->csrf_error($req, $article, "admin_add_stepparent", "Add Stepparent");
2148
31a26b52
TC
2149 $req->user_can(edit_stepparent_add => $article)
2150 or return $self->edit_form($req, $article, $articles,
2151 "You don't have access to add stepparents to this article");
2152
ca9aa2bf
TC
2153 my $cgi = $req->cgi;
2154 require 'BSE/Admin/StepParents.pm';
2155 eval {
2156 my $step_parent_id = $cgi->param('stepparent');
2157 defined($step_parent_id)
2158 or die "No stepparent supplied to add_stepparent";
2159 int($step_parent_id) eq $step_parent_id
2160 or die "Invalid stepcat supplied to add_stepcat";
2161 my $step_parent = $articles->getByPkey($step_parent_id)
31a26b52
TC
2162 or die "Parent $step_parent_id not found\n";
2163
2164 $req->user_can(edit_stepkid_add => $step_parent)
2165 or die "You don't have access to add a stepkid to that article\n";
ca9aa2bf
TC
2166
2167 my $release = $cgi->param('release');
2168 defined $release
2169 or $release = "01/01/2000";
2170 use BSE::Util::Valid qw/valid_date/;
2171 $release eq '' or valid_date($release)
2172 or die "Invalid release date";
2173 my $expire = $cgi->param('expire');
2174 defined $expire
2175 or $expire = '31/12/2999';
2176 $expire eq '' or valid_date($expire)
2177 or die "Invalid expire data";
2178
2179 my $newentry =
2180 BSE::Admin::StepParents->add($step_parent, $article, $release, $expire);
2181 };
2182 $@ and return $self->refresh($article, $cgi, 'step', $@);
2183
a0a8147b
TC
2184 use Util 'generate_article';
2185 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2186
8b0b2f34 2187 return $self->refresh($article, $cgi, 'stepparents', 'Stepparent added');
ca9aa2bf
TC
2188}
2189
2190sub del_stepparent {
2191 my ($self, $req, $article, $articles) = @_;
2192
aa6896b6
TC
2193 $req->check_csrf("admin_remove_stepparent")
2194 or return $self->csrf_error($req, $article, "admin_del_stepparent", "Delete Stepparent");
2195
31a26b52
TC
2196 $req->user_can(edit_stepparent_delete => $article)
2197 or return $self->edit_form($req, $article, $articles,
2198 "You cannot remove stepparents from that article");
2199
ca9aa2bf
TC
2200 my $cgi = $req->cgi;
2201 require 'BSE/Admin/StepParents.pm';
2202 my $step_parent_id = $cgi->param('stepparent');
2203 defined($step_parent_id)
2204 or return $self->refresh($article, $cgi, 'stepparents',
2205 "No stepparent supplied to add_stepcat");
2206 int($step_parent_id) eq $step_parent_id
2207 or return $self->refresh($article, $cgi, 'stepparents',
2208 "Invalid stepparent supplied to add_stepparent");
2209 my $step_parent = $articles->getByPkey($step_parent_id)
2210 or return $self->refresh($article, $cgi, 'stepparent',
2211 "Stepparent $step_parent_id not found");
2212
31a26b52
TC
2213 $req->user_can(edit_stepkid_delete => $step_parent)
2214 or die "You don't have access to remove the stepkid from that article\n";
2215
ca9aa2bf
TC
2216 eval {
2217 BSE::Admin::StepParents->del($step_parent, $article);
2218 };
2219 $@ and return $self->refresh($article, $cgi, 'stepparents', $@);
2220
a0a8147b
TC
2221 use Util 'generate_article';
2222 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2223
8b0b2f34 2224 return $self->refresh($article, $cgi, 'stepparents', 'Stepparent deleted');
ca9aa2bf
TC
2225}
2226
2227sub save_stepparents {
2228 my ($self, $req, $article, $articles) = @_;
2229
aa6896b6
TC
2230 $req->check_csrf("admin_save_stepparents")
2231 or return $self->csrf_error($req, $article, "admin_save_stepparents", "Save Stepparents");
31a26b52
TC
2232 $req->user_can(edit_stepparent_save => $article)
2233 or return $self->edit_form($req, $article, $articles,
2234 "No access to save stepparent data for this artice");
2235
ca9aa2bf
TC
2236 my $cgi = $req->cgi;
2237
2238 require 'BSE/Admin/StepParents.pm';
2239 my @stepparents = OtherParents->getBy(childId=>$article->{id});
2240 my %stepparents = map { $_->{parentId}, $_ } @stepparents;
2241 my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2242 for my $stepparent (@stepparents) {
31a26b52
TC
2243 $req->user_can(edit_stepkid_save => $stepparent->{parentId})
2244 or next;
ca9aa2bf
TC
2245 for my $name (qw/release expire/) {
2246 my $date = $cgi->param($name.'_'.$stepparent->{parentId});
2247 if (defined $date) {
2248 if ($date eq '') {
2249 $date = $datedefs{$name};
2250 }
2251 elsif (valid_date($date)) {
2252 use BSE::Util::SQL qw/date_to_sql/;
2253 $date = date_to_sql($date);
2254 }
2255 else {
2256 return $self->refresh($article, $cgi, "Invalid date '$date'");
2257 }
2258 $stepparent->{$name} = $date;
2259 }
2260 }
2261 eval {
2262 $stepparent->save();
2263 };
2264 $@ and return $self->refresh($article, $cgi, '', $@);
2265 }
2266
a0a8147b
TC
2267 use Util 'generate_article';
2268 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2269
8b0b2f34
TC
2270 return $self->refresh($article, $cgi, 'stepparents',
2271 'Stepparent information saved');
ca9aa2bf
TC
2272}
2273
58baa27b 2274sub refresh_url {
ca9aa2bf
TC
2275 my ($self, $article, $cgi, $name, $message, $extras) = @_;
2276
8b0b2f34 2277 my $url = $cgi->param('r');
16ac5598
TC
2278 if ($url) {
2279 if ($url !~ /[?&](m|message)=/ && $message) {
2280 # add in messages if none in the provided refresh
2281 my @msgs = ref $message ? @$message : $message;
f3fc60c0 2282 my $sep = $url =~ /\?/ ? "&" : "?";
16ac5598 2283 for my $msg (@msgs) {
f3fc60c0 2284 $url .= $sep . "m=" . CGI::escape($msg);
16ac5598
TC
2285 }
2286 }
2287 }
2288 else {
41f10371 2289 my $urlbase = admin_base_url($self->{cfg});
8b0b2f34 2290 $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
16ac5598
TC
2291 if ($message) {
2292 my @msgs = ref $message ? @$message : $message;
2293 for my $msg (@msgs) {
2294 $url .= "&m=" . CGI::escape($msg);
2295 }
2296 }
8b0b2f34
TC
2297 if ($cgi->param('_t')) {
2298 $url .= "&_t=".CGI::escape($cgi->param('_t'));
2299 }
2300 $url .= $extras if defined $extras;
2301 my $cgiextras = $cgi->param('e');
2302 $url .= "#$name" if $name;
ca9aa2bf 2303 }
ca9aa2bf 2304
58baa27b
TC
2305 return $url;
2306}
2307
2308sub refresh {
2309 my ($self, $article, $cgi, $name, $message, $extras) = @_;
2310
2311 my $url = $self->refresh_url($article, $cgi, $name, $message, $extras);
2312
ca9aa2bf
TC
2313 return BSE::Template->get_refresh($url, $self->{cfg});
2314}
2315
2316sub show_images {
918735d1 2317 my ($self, $req, $article, $articles, $msg, $errors) = @_;
ca9aa2bf
TC
2318
2319 my %acts;
918735d1 2320 %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
2321 my $template = 'admin/article_img';
2322
4d764c34 2323 return $req->dyn_response($template, \%acts);
ca9aa2bf
TC
2324}
2325
2326sub save_image_changes {
2327 my ($self, $req, $article, $articles) = @_;
2328
aa6896b6
TC
2329 $req->check_csrf("admin_save_images")
2330 or return $self->csrf_error($req, $article, "admin_save_images", "Save Images");
2331
abf5bbc6 2332 $req->user_can(edit_images_save => $article)
cc9019d1 2333 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2334 "You don't have access to save image information for this article");
2335
b95fc3a0
TC
2336 my $image_dir = cfg_image_dir($req->cfg);
2337
ca9aa2bf
TC
2338 my $cgi = $req->cgi;
2339 my $image_pos = $cgi->param('imagePos');
2340 if ($image_pos
2341 && $image_pos =~ /^(?:tl|tr|bl|br)$/
2342 && $image_pos ne $article->{imagePos}) {
2343 $article->{imagePos} = $image_pos;
2344 $article->save;
2345 }
daee3409 2346 my @images = $self->get_images($article);
4772671f
TC
2347
2348 @images or
2349 return $self->refresh($article, $cgi, undef, 'No images to save information for');
ca9aa2bf 2350
b95fc3a0
TC
2351 my %changes;
2352 my %errors;
2353 my %names;
e63c3728 2354 my %old_images;
8326f275 2355 my @new_images;
b95fc3a0
TC
2356 for my $image (@images) {
2357 my $id = $image->{id};
2358
2359 my $alt = $cgi->param("alt$id");
2360 if ($alt ne $image->{alt}) {
2361 $changes{$id}{alt} = $alt;
ca9aa2bf 2362 }
b95fc3a0
TC
2363
2364 my $url = $cgi->param("url$id");
2365 if (defined $url && $url ne $image->{url}) {
2366 $changes{$id}{url} = $url;
ca9aa2bf 2367 }
b95fc3a0
TC
2368
2369 my $name = $cgi->param("name$id");
2370 if (defined $name && $name ne $image->{name}) {
547a26ad
TC
2371 if ($name eq '') {
2372 if ($article->{id} > 0) {
2373 $changes{$id}{name} = '';
2374 }
2375 else {
2376 $errors{"name$id"} = "Identifiers are required for global images";
2377 }
2d83755d
TC
2378 }
2379 elsif ($name =~ /^[a-z_]\w*$/i) {
b95fc3a0
TC
2380 my $msg;
2381 if ($self->validate_image_name($name, \$msg)) {
2382 # check for duplicates after the loop
2383 push @{$names{lc $name}}, $image->{id}
2384 if length $name;
2385 $changes{$id}{name} = $name;
4772671f
TC
2386 }
2387 else {
b95fc3a0 2388 $errors{"name$id"} = $msg;
4772671f
TC
2389 }
2390 }
b95fc3a0
TC
2391 else {
2392 $errors{"name$id"} = 'Image name must be empty or alphanumeric and unique to the article';
2393 }
2394 }
2395 else {
2396 push @{$names{lc $image->{name}}}, $image->{id}
2397 if length $image->{name};
2398 }
2399
2400 my $filename = $cgi->param("image$id");
2401 if (defined $filename && length $filename) {
2402 my $in_fh = $cgi->upload("image$id");
2403 if ($in_fh) {
2404 # work out where to put it
2405 require DevHelp::FileUpload;
daee3409 2406 my $msg;
b95fc3a0
TC
2407 my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
2408 ($image_dir, $filename . '', \$msg);
2409 if ($image_name) {
2410 local $/ = \8192;
2411 my $data;
2412 while ($data = <$in_fh>) {
2413 print $out_fh $data;
2414 }
2415 close $out_fh;
2416
2417 my $full_filename = "$image_dir/$image_name";
2418 require Image::Size;
2419 my ($width, $height, $type) = Image::Size::imgsize($full_filename);
2420 if ($width) {
e63c3728
TC
2421 $old_images{$id} =
2422 {
2423 image => $image->{image},
2424 storage => $image->{storage}
2425 };
8326f275
TC
2426 push @new_images, $image_name;
2427
b95fc3a0 2428 $changes{$id}{image} = $image_name;
e63c3728
TC
2429 $changes{$id}{storage} = 'local';
2430 $changes{$id}{src} = "/images/$image_name";
b95fc3a0
TC
2431 $changes{$id}{width} = $width;
2432 $changes{$id}{height} = $height;
5d1b1cbb 2433 $changes{$id}{ftype} = $self->_image_ftype($type);
b95fc3a0
TC
2434 }
2435 else {
2436 $errors{"image$id"} = $type;
2437 }
2438 }
2439 else {
2440 $errors{"image$id"} = $msg;
2441 }
2442 }
2443 else {
2444 # problem uploading
2445 $errors{"image$id"} = "No image file received";
2446 }
2447 }
2448 }
2449 # look for duplicate names
2450 for my $name (keys %names) {
2451 if (@{$names{$name}} > 1) {
2452 for my $id (@{$names{$name}}) {
2453 $errors{"name$id"} = 'Image name must be unique to the article';
daee3409 2454 }
4772671f
TC
2455 }
2456 }
8326f275
TC
2457 if (keys %errors) {
2458 # remove files that won't be stored because validation failed
2459 unlink map "$image_dir/$_", @new_images;
2460
2461 return $self->edit_form($req, $article, $articles, undef,
2462 \%errors);
2463 }
b95fc3a0 2464
e63c3728
TC
2465 my $mgr = $self->_image_manager($req->cfg);
2466 $req->flash('Image information saved');
2467 my $changes_found = 0;
2468 my $auto_store = $cgi->param('auto_storage');
2469 for my $image (@images) {
2470 my $id = $image->{id};
2471
2472 if ($changes{$id}) {
2473 my $changes = $changes{$id};
2474 ++$changes_found;
2475
2476 for my $field (keys %$changes) {
2477 $image->{$field} = $changes->{$field};
b95fc3a0 2478 }
ca9aa2bf
TC
2479 $image->save;
2480 }
a0a8147b 2481
e63c3728
TC
2482 my $old_storage = $image->{storage};
2483 my $new_storage = $auto_store ? '' : $cgi->param("storage$id");
2484 defined $new_storage or $new_storage = $image->{storage};
2485 $new_storage = $mgr->select_store($image->{image}, $new_storage, $image);
2486 if ($new_storage ne $old_storage) {
2487 eval {
2488 $image->{src} = $mgr->store($image->{image}, $new_storage, $image);
2489 $image->{storage} = $new_storage;
2490 $image->save;
2491 };
2492
2493 if ($old_storage ne 'local') {
2494 $mgr->unstore($image->{image}, $old_storage);
2495 }
2496 }
2497 }
2498
2499 # delete any image files that were replaced
2500 for my $old_image (values %old_images) {
2501 my ($image, $storage) = @$old_image{qw/image storage/};
2502 if ($storage ne 'local') {
2503 $mgr->unstore($image->{image}, $storage);
2504 }
2505 unlink "$image_dir/$image";
2506 }
2507
2508 if ($changes_found) {
b95fc3a0
TC
2509 use Util 'generate_article';
2510 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2511 }
e63c3728
TC
2512
2513 return $self->refresh($article, $cgi);
ca9aa2bf
TC
2514}
2515
58baa27b
TC
2516=item _service_error
2517
2518This function is called on various errors.
2519
2520If a _service parameter was supplied, returns text like:
2521
2522=over
2523
2524Result: failure
2525
2526Field-Error: I<field-name1> - I<message1>
2527
2528Field-Error: I<field-name2> - I<message2>
2529
2530=back
2531
2532If the request is detected as an ajax request or a _ parameter is
2533supplied, return JSON like:
2534
2535 { error: I<message> }
2536
2537Otherwise display the normal edit page with the error.
2538
2539=cut
2540
dbcd12e5 2541sub _service_error {
60bc6601 2542 my ($self, $req, $article, $articles, $msg, $error, $code) = @_;
dbcd12e5 2543
f3fc60c0
TC
2544 unless ($article) {
2545 my $mymsg;
2546 $article = $self->_dummy_article($req, $articles, \$mymsg);
2547 $article ||=
2548 {
2549 map $_ => '', Article->columns
2550 };
2551 }
2552
dbcd12e5
TC
2553 if ($req->cgi->param('_service')) {
2554 my $body = '';
2555 $body .= "Result: failure\n";
2556 if (ref $error) {
2557 for my $field (keys %$error) {
2558 my $text = $error->{$field};
2559 $text =~ tr/\n/ /;
2560 $body .= "Field-Error: $field - $text\n";
2561 }
2562 my $text = join ('/', values %$error);
2563 $text =~ tr/\n/ /;
2564 $body .= "Error: $text\n";
2565 }
58baa27b
TC
2566 elsif ($msg) {
2567 $body .= "Error: $msg\n";
2568 }
dbcd12e5
TC
2569 else {
2570 $body .= "Error: $error\n";
2571 }
2572 return
2573 {
2574 type => 'text/plain',
2575 content => $body,
2576 };
2577 }
58baa27b
TC
2578 elsif ((() = $req->cgi->param('_')) ||
2579 (defined $ENV{HTTP_X_REQUESTED_WITH}
2580 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/)) {
9b3a5df0
TC
2581 $error ||= {};
2582 my $result = { errors => $error };
2583 $msg and $result->{message} = $msg;
60bc6601 2584 $code and $result->{error_code} = $code;
9b3a5df0 2585 return $req->json_content($result);
58baa27b 2586 }
dbcd12e5 2587 else {
bf87e97c 2588 return $self->edit_form($req, $article, $articles, $msg, $error);
dbcd12e5
TC
2589 }
2590}
2591
2592sub _service_success {
2593 my ($self, $results) = @_;
2594
2595 my $body = "Result: success\n";
2596 for my $field (keys %$results) {
2597 $body .= "$field: $results->{$field}\n";
2598 }
2599 return
2600 {
2601 type => 'text/plain',
2602 content => $body,
2603 };
2604}
2605
5d1b1cbb
TC
2606sub _image_ftype {
2607 my ($self, $type) = @_;
2608
2609 if ($type eq 'CWS' || $type eq 'SWF') {
2610 return "flash";
2611 }
2612
2613 return "img";
2614}
2615
bf87e97c
TC
2616sub do_add_image {
2617 my ($self, $cfg, $article, $image, %opts) = @_;
ca9aa2bf 2618
bf87e97c
TC
2619 my $errors = $opts{errors}
2620 or die "No errors parameter";
ca9aa2bf 2621
bf87e97c 2622 my $imageref = $opts{name};
d794b180 2623 if (defined $imageref && $imageref ne '') {
4772671f
TC
2624 if ($imageref =~ /^[a-z_]\w+$/i) {
2625 # make sure it's unique
daee3409 2626 my @images = $self->get_images($article);
4772671f
TC
2627 for my $img (@images) {
2628 if (defined $img->{name} && lc $img->{name} eq lc $imageref) {
bf87e97c 2629 $errors->{name} = 'Image name must be unique to the article';
4772671f
TC
2630 last;
2631 }
2632 }
2633 }
2634 else {
bf87e97c 2635 $errors->{name} = 'Image name must be empty or alphanumeric beginning with an alpha character';
4772671f
TC
2636 }
2637 }
2638 else {
2639 $imageref = '';
2640 }
bf87e97c 2641 unless ($errors->{name}) {
d09682dd
TC
2642 my $workmsg;
2643 $self->validate_image_name($imageref, \$workmsg)
bf87e97c 2644 or $errors->{name} = $workmsg;
daee3409 2645 }
4772671f 2646
4772671f
TC
2647 if ($image) {
2648 if (-z $image) {
bf87e97c 2649 $errors->{image} = 'Image file is empty';
4772671f 2650 }
ca9aa2bf 2651 }
4772671f 2652 else {
bf87e97c 2653 $errors->{image} = 'Please enter an image filename';
ca9aa2bf 2654 }
bf87e97c
TC
2655 keys %$errors
2656 and return;
4772671f 2657
bf87e97c 2658 my $imagename = $opts{filename} || $image;
ca9aa2bf
TC
2659 $imagename .= ''; # force it into a string
2660 my $basename = '';
bf87e97c 2661 $imagename =~ tr/ //d;
ca9aa2bf
TC
2662 $imagename =~ /([\w.-]+)$/ and $basename = $1;
2663
2664 # create a filename that we hope is unique
2665 my $filename = time. '_'. $basename;
2666
2667 # for the sysopen() constants
2668 use Fcntl;
2669
bf87e97c 2670 my $imagedir = cfg_image_dir($cfg);
ca9aa2bf
TC
2671 # loop until we have a unique filename
2672 my $counter="";
2673 $filename = time. '_' . $counter . '_' . $basename
2674 until sysopen( OUTPUT, "$imagedir/$filename", O_WRONLY| O_CREAT| O_EXCL)
2675 || ++$counter > 100;
2676
2677 fileno(OUTPUT) or die "Could not open image file: $!";
2678
2679 # for OSs with special text line endings
2680 binmode OUTPUT;
2681
2682 my $buffer;
2683
2684 no strict 'refs';
2685
2686 # read the image in from the browser and output it to our output filehandle
2687 print OUTPUT $buffer while read $image, $buffer, 1024;
2688
2689 # close and flush
2690 close OUTPUT
2691 or die "Could not close image file $filename: $!";
2692
2693 use Image::Size;
2694
2695
f40af7e2 2696 my($width,$height, $type) = imgsize("$imagedir/$filename");
ca9aa2bf 2697
bf87e97c 2698 my $alt = $opts{alt};
ca9aa2bf 2699 defined $alt or $alt = '';
bf87e97c 2700 my $url = $opts{url};
ca9aa2bf
TC
2701 defined $url or $url = '';
2702 my %image =
2703 (
2704 articleId => $article->{id},
2705 image => $filename,
2706 alt=>$alt,
2707 width=>$width,
2708 height => $height,
2709 url => $url,
2710 displayOrder=>time,
4772671f 2711 name => $imageref,
e63c3728
TC
2712 storage => 'local',
2713 src => '/images/' . $filename,
5d1b1cbb 2714 ftype => $self->_image_ftype($type),
ca9aa2bf 2715 );
f40af7e2
TC
2716 require BSE::TB::Images;
2717 my @cols = BSE::TB::Image->columns;
ca9aa2bf 2718 shift @cols;
f40af7e2 2719 my $imageobj = BSE::TB::Images->add(@image{@cols});
a0a8147b 2720
bf87e97c 2721 my $storage = $opts{storage};
e63c3728 2722 defined $storage or $storage = 'local';
bf87e97c 2723 my $image_manager = $self->_image_manager($cfg);
e63c3728
TC
2724 local $SIG{__DIE__};
2725 eval {
2726 my $src;
2727 $storage = $image_manager->select_store($filename, $storage, $imageobj);
2728 $src = $image_manager->store($filename, $storage, $imageobj);
2729
2730 if ($src) {
2731 $imageobj->{src} = $src;
2732 $imageobj->{storage} = $storage;
2733 $imageobj->save;
2734 }
2735 };
2736 if ($@) {
bf87e97c 2737 $errors->{flash} = $@;
e63c3728
TC
2738 }
2739
bf87e97c
TC
2740 return $imageobj;
2741}
2742
2743sub add_image {
2744 my ($self, $req, $article, $articles) = @_;
2745
aa6896b6
TC
2746 $req->check_csrf("admin_add_image")
2747 or return $self->csrf_error($req, $article, "admin_add_image", "Add Image");
bf87e97c
TC
2748 $req->user_can(edit_images_add => $article)
2749 or return $self->_service_error($req, $article, $articles,
2750 "You don't have access to add new images to this article");
2751
2752 my $cgi = $req->cgi;
2753 my %errors;
2754 my $imageobj =
2755 $self->do_add_image
2756 (
2757 $req->cfg,
2758 $article,
2759 scalar($cgi->param('image')),
2760 name => scalar($cgi->param('name')),
2761 alt => scalar($cgi->param('altIn')),
2762 url => scalar($cgi->param('url')),
2763 storage => scalar($cgi->param('storage')),
2764 errors => \%errors,
2765 );
2766
2767 $imageobj
2768 or return $self->_service_error($req, $article, $articles, undef, \%errors);
2769
2770 # typically a soft failure from the storage
2771 $errors{flash}
2772 and $req->flash($errors{flash});
2773
a0a8147b
TC
2774 use Util 'generate_article';
2775 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2776
dbcd12e5
TC
2777 if ($cgi->param('_service')) {
2778 return $self->_service_success
2779 (
2780 {
2781 image => $imageobj->{id},
2782 },
2783 );
2784 }
2785 else {
2786 return $self->refresh($article, $cgi, undef, 'New image added');
2787 }
ca9aa2bf
TC
2788}
2789
e63c3728
TC
2790sub _image_manager {
2791 my ($self) = @_;
2792
2793 require BSE::StorageMgr::Images;
2794
2795 return BSE::StorageMgr::Images->new(cfg => $self->cfg);
2796}
2797
ca9aa2bf
TC
2798# remove an image
2799sub remove_img {
2800 my ($self, $req, $article, $articles, $imageid) = @_;
2801
aa6896b6
TC
2802 $req->check_csrf("admin_remove_image")
2803 or return $self->csrf_error($req, $article, "admin_remove_image", "Remove Image");
2804
abf5bbc6 2805 $req->user_can(edit_images_delete => $article)
cc9019d1 2806 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2807 "You don't have access to delete images from this article");
2808
ca9aa2bf
TC
2809 $imageid or die;
2810
daee3409 2811 my @images = $self->get_images($article);
ca9aa2bf
TC
2812 my ($image) = grep $_->{id} == $imageid, @images
2813 or return $self->show_images($req, $article, $articles, "No such image");
e63c3728
TC
2814
2815 if ($image->{storage} ne 'local') {
2816 my $mgr = $self->_image_manager($req->cfg);
2817 $mgr->unstore($image->{image}, $image->{storage});
2818 }
2819
ab2cd916 2820 my $imagedir = cfg_image_dir($req->cfg);
6473c56f 2821 unlink "$imagedir$image->{image}";
ca9aa2bf
TC
2822 $image->remove;
2823
a0a8147b
TC
2824 use Util 'generate_article';
2825 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2826
cc9019d1 2827 return $self->refresh($article, $req->cgi, undef, 'Image removed');
ca9aa2bf
TC
2828}
2829
2830sub move_img_up {
2831 my ($self, $req, $article, $articles) = @_;
2832
aa6896b6
TC
2833 $req->check_csrf("admin_move_image")
2834 or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
abf5bbc6 2835 $req->user_can(edit_images_reorder => $article)
cc9019d1 2836 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2837 "You don't have access to reorder images in this article");
2838
ca9aa2bf 2839 my $imageid = $req->cgi->param('imageid');
daee3409 2840 my @images = $self->get_images($article);
ca9aa2bf 2841 my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
cc9019d1 2842 or return $self->edit_form($req, $article, $articles, "No such image");
ca9aa2bf 2843 $imgindex > 0
cc9019d1 2844 or return $self->edit_form($req, $article, $articles, "Image is already at the top");
ca9aa2bf
TC
2845 my ($to, $from) = @images[$imgindex-1, $imgindex];
2846 ($to->{displayOrder}, $from->{displayOrder}) =
2847 ($from->{displayOrder}, $to->{displayOrder});
2848 $to->save;
2849 $from->save;
2850
a0a8147b
TC
2851 use Util 'generate_article';
2852 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2853
cc9019d1 2854 return $self->refresh($article, $req->cgi, undef, 'Image moved');
ca9aa2bf
TC
2855}
2856
2857sub move_img_down {
2858 my ($self, $req, $article, $articles) = @_;
2859
aa6896b6
TC
2860 $req->check_csrf("admin_move_image")
2861 or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
abf5bbc6 2862 $req->user_can(edit_images_reorder => $article)
cc9019d1 2863 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2864 "You don't have access to reorder images in this article");
2865
ca9aa2bf 2866 my $imageid = $req->cgi->param('imageid');
daee3409 2867 my @images = $self->get_images($article);
ca9aa2bf 2868 my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
cc9019d1 2869 or return $self->edit_form($req, $article, $articles, "No such image");
ca9aa2bf 2870 $imgindex < $#images
cc9019d1 2871 or return $self->edit_form($req, $article, $articles, "Image is already at the end");
ca9aa2bf
TC
2872 my ($to, $from) = @images[$imgindex+1, $imgindex];
2873 ($to->{displayOrder}, $from->{displayOrder}) =
2874 ($from->{displayOrder}, $to->{displayOrder});
2875 $to->save;
2876 $from->save;
2877
a0a8147b
TC
2878 use Util 'generate_article';
2879 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2880
cc9019d1 2881 return $self->refresh($article, $req->cgi, undef, 'Image moved');
ca9aa2bf
TC
2882}
2883
ab2cd916
TC
2884sub req_thumb {
2885 my ($self, $req, $article) = @_;
2886
2887 my $cgi = $req->cgi;
2888 my $cfg = $req->cfg;
2889 my $im_id = $cgi->param('im');
2890 my $image;
2891 if (defined $im_id && $im_id =~ /^\d+$/) {
6a8a6ac5 2892 ($image) = grep $_->{id} == $im_id, $self->get_images($article);
ab2cd916
TC
2893 }
2894 my $thumb_obj = $self->_get_thumbs_class();
2895 my ($data, $type);
2896 if ($image && $thumb_obj) {
195977cd
TC
2897 my $geometry_id = $cgi->param('g');
2898 defined $geometry_id or $geometry_id = 'editor';
dbcd12e5 2899 my $geometry = $cfg->entry('thumb geometries', $geometry_id, 'scale(200x200)');
ab2cd916
TC
2900 my $imagedir = $cfg->entry('paths', 'images', $Constants::IMAGEDIR);
2901
195977cd 2902 my $error;
6430ee52
TC
2903 ($data, $type) = $thumb_obj->thumb_data
2904 (
2905 filename => "$imagedir/$image->{image}",
2906 geometry => $geometry,
2907 error => \$error
2908 )
d9f8d6b9
TC
2909 or return
2910 {
2911 type => 'text/plain',
2912 content => 'Error: '.$error
2913 };
ab2cd916
TC
2914 }
2915
2916 if ($type && $data) {
2917
2918 return
2919 {
2920 type => $type,
2921 content => $data,
2922 headers => [
2923 "Content-Length: ".length($data),
2924 "Cache-Control: max-age=3600",
2925 ],
2926 };
2927 }
2928 else {
2929 # grab the nothumb image
2930 my $uri = $cfg->entry('editor', 'default_thumbnail', '/images/admin/nothumb.png');
2931 my $filebase = $Constants::CONTENTBASE;
2932 if (open IMG, "<$filebase/$uri") {
2933 binmode IMG;
2934 my $data = do { local $/; <IMG> };
2935 close IMG;
2936 my $type = $uri =~ /\.(\w+)$/ ? $1 : 'png';
2937 return
2938 {
2939 type => "image/$type",
2940 content => $data,
2941 headers => [ "Content-Length: ".length($data) ],
2942 };
2943 }
2944 else {
2945 return
2946 {
2947 type=>"text/html",
2948 content => "<html><body>Cannot make thumb or default image</body></html>",
2949 };
2950 }
2951 }
2952}
2953
b95fc3a0
TC
2954sub req_edit_image {
2955 my ($self, $req, $article, $articles, $errors) = @_;
2956
2957 my $cgi = $req->cgi;
2958
2959 my $id = $cgi->param('image_id');
2960
7303cf10 2961 my ($image) = grep $_->{id} == $id, $self->get_images($article)
b95fc3a0
TC
2962 or return $self->edit_form($req, $article, $articles,
2963 "No such image");
2964 $req->user_can(edit_images_save => $article)
2965 or return $self->edit_form($req, $article, $articles,
2966 "You don't have access to save image information for this article");
2967
2968 my %acts;
2969 %acts =
2970 (
2971 $self->low_edit_tags(\%acts, $req, $article, $articles, undef,
2972 $errors),
2973 eimage => [ \&tag_hash, $image ],
7303cf10 2974 error_img => [ \&tag_error_img, $req->cfg, $errors ],
b95fc3a0
TC
2975 );
2976
2977 return $req->response('admin/image_edit', \%acts);
2978}
2979
2980sub req_save_image {
2981 my ($self, $req, $article, $articles) = @_;
2982
aa6896b6
TC
2983 $req->check_csrf("admin_save_image")
2984 or return $self->csrf_error($req, $article, "admin_save_image", "Save Image");
b95fc3a0
TC
2985 my $cgi = $req->cgi;
2986
2987 my $id = $cgi->param('image_id');
2988
7303cf10 2989 my @images = $self->get_images($article);
b95fc3a0
TC
2990 my ($image) = grep $_->{id} == $id, @images
2991 or return $self->edit_form($req, $article, $articles,
2992 "No such image");
2993 $req->user_can(edit_images_save => $article)
2994 or return $self->edit_form($req, $article, $articles,
2995 "You don't have access to save image information for this article");
2996
2997 my $image_dir = cfg_image_dir($req->cfg);
2998
e63c3728
TC
2999 my $old_storage = $image->{storage};
3000
b95fc3a0
TC
3001 my %errors;
3002 my $delete_file;
3003 my $alt = $cgi->param('alt');
3004 defined $alt and $image->{alt} = $alt;
3005 my $url = $cgi->param('url');
3006 defined $url and $image->{url} = $url;
3007 my @other_images = grep $_->{id} != $id, @images;
3008 my $name = $cgi->param('name');
3009 if (defined $name) {
3010 if (length $name) {
3011 if ($name !~ /^[a-z_]\w*$/i) {
3012 $errors{name} = 'Image name must be empty or alphanumeric and unique to the article';
3013 }
3014 elsif (grep $name eq $_->{name}, @other_images) {
3015 $errors{name} = 'Image name must be unique to the article';
3016 }
3017 else {
3018 $image->{name} = $name;
3019 }
3020 }
2d83755d 3021 else {
547a26ad
TC
3022 if ($article->{id} == -1) {
3023 $errors{name} = "Identifiers are required for global images";
3024 }
3025 else {
3026 $image->{name} = '';
3027 }
2d83755d 3028 }
b95fc3a0
TC
3029 }
3030 my $filename = $cgi->param('image');
3031 if (defined $filename && length $filename) {
3032 my $in_fh = $cgi->upload('image');
3033 if ($in_fh) {
3034 require DevHelp::FileUpload;
3035 my $msg;
3036 my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3037 ($image_dir, $filename . '', \$msg);
3038 if ($image_name) {
3039 {
3040 local $/ = \8192;
3041 my $data;
3042 while ($data = <$in_fh>) {
3043 print $out_fh $data;
3044 }
3045 close $out_fh;
3046 }
3047
3048 my $full_filename = "$image_dir/$image_name";
3049 require Image::Size;
3050 my ($width, $height, $type) = Image::Size::imgsize($full_filename);
3051 if ($width) {
3052 $delete_file = $image->{image};
3053 $image->{image} = $image_name;
3054 $image->{width} = $width;
3055 $image->{height} = $height;
e63c3728
TC
3056 $image->{storage} = 'local'; # not on the remote store yet
3057 $image->{src} = '/images/' . $image_name;
5d1b1cbb 3058 $image->{ftype} = $self->_image_ftype($type);
b95fc3a0
TC
3059 }
3060 else {
3061 $errors{image} = $type;
3062 }
3063 }
3064 else {
3065 $errors{image} = $msg;
3066 }
3067 }
3068 else {
3069 $errors{image} = "No image file received";
3070 }
3071 }
3072 keys %errors
3073 and return $self->req_edit_image($req, $article, $articles, \%errors);
3074
e63c3728
TC
3075 my $new_storage = $cgi->param('storage');
3076 defined $new_storage or $new_storage = $image->{storage};
b95fc3a0 3077 $image->save;
e63c3728
TC
3078 my $mgr = $self->_image_manager($req->cfg);
3079 if ($delete_file) {
3080 if ($old_storage ne 'local') {
3081 $mgr->unstore($delete_file, $old_storage);
3082 }
3083 unlink "$image_dir/$delete_file";
3084 }
3085 $req->flash("Image saved");
3086 eval {
3087 $new_storage =
3088 $mgr->select_store($image->{image}, $new_storage);
3089 if ($image->{storage} ne $new_storage) {
3090 # handles both new images (which sets storage to local) and changing
3091 # the storage for old images
3092 my $old_storage = $image->{storage};
3093 my $src = $mgr->store($image->{image}, $new_storage, $image);
3094 $image->{src} = $src;
3095 $image->{storage} = $new_storage;
3096 $image->save;
3097 }
3098 };
3099 $@ and $req->flash("There was a problem adding it to the new storage: $@");
3100 if ($image->{storage} ne $old_storage && $old_storage ne 'local') {
3101 eval {
3102 $mgr->unstore($image->{image}, $old_storage);
3103 };
3104 $@ and $req->flash("There was a problem removing if from the old storage: $@");
3105 }
b95fc3a0 3106
e63c3728 3107 return $self->refresh($article, $cgi);
b95fc3a0
TC
3108}
3109
ca9aa2bf
TC
3110sub get_article {
3111 my ($self, $articles, $article) = @_;
3112
3113 return $article;
3114}
3115
3116sub table_object {
3117 my ($self, $articles) = @_;
3118
3119 $articles;
3120}
3121
ca9aa2bf 3122sub _refresh_filelist {
8b0b2f34 3123 my ($self, $req, $article, $msg) = @_;
ca9aa2bf 3124
cc9019d1 3125 return $self->refresh($article, $req->cgi, undef, $msg);
ca9aa2bf
TC
3126}
3127
3128sub filelist {
918735d1 3129 my ($self, $req, $article, $articles, $msg, $errors) = @_;
ca9aa2bf
TC
3130
3131 my %acts;
918735d1 3132 %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
3133 my $template = 'admin/filelist';
3134
3135 return BSE::Template->get_response($template, $req->cfg, \%acts);
3136}
3137
4b69925d
TC
3138my %file_fields =
3139 (
3140 file =>
3141 {
3142 maxlength => MAX_FILE_DISPLAYNAME_LENGTH,
3143 description => 'Filename'
3144 },
3145 description =>
3146 {
3147 rules => 'dh_one_line',
3148 maxlength => 255,
3149 description => 'Description',
3150 },
3151 name =>
3152 {
3153 description => 'Identifier',
3154 maxlength => 80,
3155 },
6430ee52
TC
3156 category =>
3157 {
3158 description => "Category",
3159 maxlength => 20,
3160 },
4b69925d
TC
3161 );
3162
ca9aa2bf
TC
3163sub fileadd {
3164 my ($self, $req, $article, $articles) = @_;
3165
aa6896b6
TC
3166 $req->check_csrf("admin_add_file")
3167 or return $self->csrf_error($req, $article, "admin_add_file", "Add File");
abf5bbc6 3168 $req->user_can(edit_files_add => $article)
cc9019d1 3169 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
3170 "You don't have access to add files to this article");
3171
ca9aa2bf
TC
3172 my %file;
3173 my $cgi = $req->cgi;
6430ee52
TC
3174 require BSE::TB::ArticleFiles;
3175 my @cols = BSE::TB::ArticleFile->columns;
ca9aa2bf
TC
3176 shift @cols;
3177 for my $col (@cols) {
3178 if (defined $cgi->param($col)) {
3179 $file{$col} = $cgi->param($col);
3180 }
3181 }
c5286ebe
TC
3182
3183 my %errors;
ca9aa2bf 3184
4b69925d
TC
3185 $req->validate(errors => \%errors,
3186 fields => \%file_fields,
3187 section => $article->{id} == -1 ? 'Global File Validation' : 'Article File Validation');
7646d96e 3188
ca9aa2bf
TC
3189 # build a filename
3190 my $file = $cgi->param('file');
3191 unless ($file) {
c5286ebe 3192 $errors{file} = 'Please enter a filename';
ca9aa2bf 3193 }
c5286ebe
TC
3194 if ($file && -z $file) {
3195 $errors{file} = 'File is empty';
ca9aa2bf 3196 }
7646d96e
TC
3197
3198 $file{forSale} = 0 + exists $file{forSale};
3199 $file{articleId} = $article->{id};
3200 $file{download} = 0 + exists $file{download};
3201 $file{requireUser} = 0 + exists $file{requireUser};
3202 $file{hide_from_list} = 0 + exists $file{hide_from_list};
3203 $file{category} ||= '';
c5286ebe
TC
3204
3205 defined $file{name} or $file{name} = '';
9366cd70
TC
3206 if ($article->{id} == -1 && $file{name} eq '') {
3207 $errors{name} = 'Identifier is required for global files';
3208 }
3209 if (!$errors{name} && length $file{name} && $file{name} !~/^\w+$/) {
c5286ebe
TC
3210 $errors{name} = "Identifier must be a single word";
3211 }
3212 if (!$errors{name} && length $file{name}) {
9366cd70 3213 my @files = $self->get_files($article);
c5286ebe
TC
3214 if (grep lc $_->{name} eq lc $file{name}, @files) {
3215 $errors{name} = "Duplicate file identifier $file{name}";
3216 }
3217 }
3218
3219 keys %errors
3220 and return $self->edit_form($req, $article, $articles, undef, \%errors);
ca9aa2bf
TC
3221
3222 my $basename = '';
6a8a205a
TC
3223 my $workfile = $file;
3224 $workfile =~ s![^\w.:/\\-]+!_!g;
3225 $workfile =~ tr/_/_/s;
3226 $workfile =~ /([ \w.-]+)$/ and $basename = $1;
f0543260 3227 $basename =~ tr/ /_/;
7646d96e
TC
3228 $file{displayName} = $basename;
3229 $file{file} = $file;
ca9aa2bf 3230
7646d96e
TC
3231 local $SIG{__DIE__};
3232 my $fileobj =
3233 eval {
3234 $article->add_file($self->cfg, %file);
3235 };
4b69925d 3236
7646d96e
TC
3237 $fileobj
3238 or return $self->edit_form($req, $article, $articles, $@);
4b69925d 3239
7646d96e 3240 $req->flash("New file added");
ca9aa2bf 3241
cf34aa90 3242 my $storage = $cgi->param("storage") || "";
7646d96e
TC
3243 eval {
3244 my $msg;
ca9aa2bf 3245
7646d96e 3246 $article->apply_storage($self->cfg, $fileobj, $storage, \$msg);
ca9aa2bf 3247
7646d96e
TC
3248 $msg and $req->flash($msg);
3249 };
3250 $@
3251 and $req->flash($@);
ca9aa2bf 3252
7646d96e 3253# my $downloadPath = $self->{cfg}->entryVar('paths', 'downloads');
ca9aa2bf 3254
ca9aa2bf 3255
7646d96e
TC
3256# unless ($file{contentType}) {
3257# unless ($file =~ /\.([^.]+)$/) {
3258# $file{contentType} = "application/octet-stream";
3259# }
3260# unless ($file{contentType}) {
3261# $file{contentType} = content_type($self->cfg, $file);
3262# }
3263# }
ca9aa2bf 3264
ca9aa2bf 3265
7646d96e
TC
3266# # if the user supplies a really long filename, it can overflow the
3267# # filename field
ca9aa2bf 3268
7646d96e
TC
3269# my $work_filename = $basename;
3270# if (length $work_filename > 60) {
3271# $work_filename = substr($work_filename, -60);
3272# }
ca9aa2bf 3273
7646d96e 3274# my $filename = time. '_'. $work_filename;
ca9aa2bf 3275
7646d96e
TC
3276# # for the sysopen() constants
3277# use Fcntl;
e63c3728 3278
7646d96e
TC
3279# # loop until we have a unique filename
3280# my $counter="";
3281# $filename = time. '_' . $counter . '_' . $work_filename
3282# until sysopen( OUTPUT, "$downloadPath/$filename",
3283# O_WRONLY| O_CREAT| O_EXCL)
3284# || ++$counter > 100;
e63c3728 3285
7646d96e 3286# fileno(OUTPUT) or die "Could not open file: $!";
6430ee52 3287
7646d96e
TC
3288# # for OSs with special text line endings
3289# binmode OUTPUT;
e63c3728 3290
7646d96e
TC
3291# my $buffer;
3292
3293# no strict 'refs';
3294
3295# # read the image in from the browser and output it to our output filehandle
3296# print OUTPUT $buffer while read $file, $buffer, 8192;
3297
3298# # close and flush
3299# close OUTPUT
3300# or die "Could not close file $filename: $!";
3301
3302# use BSE::Util::SQL qw/now_datetime/;
3303# $file{filename} = $filename;
3304# $file{displayName} = $basename;
3305# $file{sizeInBytes} = -s $file;
3306# $file{displayOrder} = time;
3307# $file{whenUploaded} = now_datetime();
3308# $file{storage} = 'local';
3309# $file{src} = '';
3310# $file{file_handler} = "";
3311
3312# require BSE::TB::ArticleFiles;
3313# my $fileobj = BSE::TB::ArticleFiles->add(@file{@cols});
3314
3315# my $storage = $cgi->param('storage');
3316# defined $storage or $storage = 'local';
3317# my $file_manager = $self->_file_manager($req->cfg);
3318
3319# local $SIG{__DIE__};
3320# eval {
3321# my $src;
3322# $storage = $self->_select_filestore($req, $file_manager, $storage, $fileobj);
3323# $src = $file_manager->store($filename, $storage, $fileobj);
3324
3325# if ($src) {
3326# $fileobj->{src} = $src;
3327# $fileobj->{storage} = $storage;
3328# $fileobj->save;
3329# }
3330# };
3331# if ($@) {
3332# $req->flash($@);
3333# }
3334
3335# $fileobj->set_handler($req->cfg);
3336# $fileobj->save;
6430ee52 3337
a0a8147b
TC
3338 use Util 'generate_article';
3339 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3340
e63c3728 3341 $self->_refresh_filelist($req, $article);
ca9aa2bf
TC
3342}
3343
3344sub fileswap {
3345 my ($self, $req, $article, $articles) = @_;
3346
aa6896b6
TC
3347 $req->check_csrf("admin_move_file")
3348 or return $self->csrf_error($req, $article, "admin_move_file", "Move File");
3349
abf5bbc6 3350 $req->user_can('edit_files_reorder', $article)
cc9019d1 3351 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
3352 "You don't have access to reorder files in this article");
3353
ca9aa2bf
TC
3354 my $cgi = $req->cgi;
3355 my $id1 = $cgi->param('file1');
3356 my $id2 = $cgi->param('file2');
3357
3358 if ($id1 && $id2) {
9366cd70 3359 my @files = $self->get_files($article);
ca9aa2bf
TC
3360
3361 my ($file1) = grep $_->{id} == $id1, @files;
3362 my ($file2) = grep $_->{id} == $id2, @files;
3363
3364 if ($file1 && $file2) {
3365 ($file1->{displayOrder}, $file2->{displayOrder})
3366 = ($file2->{displayOrder}, $file1->{displayOrder});
3367 $file1->save;
3368 $file2->save;
3369 }
3370 }
3371
a0a8147b
TC
3372 use Util 'generate_article';
3373 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3374
9063386f 3375 $self->refresh($article, $req->cgi, undef, 'File moved');
ca9aa2bf
TC
3376}
3377
3378sub filedel {
3379 my ($self, $req, $article, $articles) = @_;
3380
aa6896b6
TC
3381 $req->check_csrf("admin_remove_file")
3382 or return $self->csrf_error($req, $article, "admin_remove_file", "Delete File");
abf5bbc6 3383 $req->user_can('edit_files_delete', $article)
cc9019d1
TC
3384 or return $self->edit_form($req, $article, $articles,
3385 "You don't have access to delete files from this article");
abf5bbc6 3386
ca9aa2bf
TC
3387 my $cgi = $req->cgi;
3388 my $fileid = $cgi->param('file');
3389 if ($fileid) {
9366cd70 3390 my @files = $self->get_files($article);
ca9aa2bf
TC
3391
3392 my ($file) = grep $_->{id} == $fileid, @files;
3393
3394 if ($file) {
e63c3728 3395 if ($file->{storage} ne 'local') {
7646d96e 3396 my $mgr = $self->_file_manager($self->cfg);
81ad8108 3397 $mgr->unstore($file->{filename}, $file->{storage});
e63c3728
TC
3398 }
3399
16901a2a 3400 $file->remove($req->cfg);
ca9aa2bf
TC
3401 }
3402 }
3403
a0a8147b
TC
3404 use Util 'generate_article';
3405 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3406
8b0b2f34 3407 $self->_refresh_filelist($req, $article, 'File deleted');
ca9aa2bf
TC
3408}
3409
3410sub filesave {
abf5bbc6 3411 my ($self, $req, $article, $articles) = @_;
ca9aa2bf 3412
aa6896b6
TC
3413 $req->check_csrf("admin_save_files")
3414 or return $self->csrf_error($req, $article, "admin_save_files", "Save Files");
3415
abf5bbc6