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