return json errors to ajax for add new 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 }
39c06424
TC
1543 $self->validate(\%data, $articles, \%errors);
1544 if (keys %errors) {
1545 if ($req->is_ajax) {
1546 return $req->json_content
1547 (
1548 success => 0,
1549 errors => \%errors,
1550 error_code => "FIELD",
1551 message => $req->message(\%errors),
1552 );
1553 }
1554 else {
1555 return $self->add_form($req, $articles, $msg, \%errors);
1556 }
1557 }
ca9aa2bf
TC
1558
1559 my $parent;
39c06424
TC
1560 my $parent_msg;
1561 my $parent_code;
ca9aa2bf
TC
1562 if ($data{parentid} > 0) {
1563 $parent = $articles->getByPkey($data{parentid}) or die;
39c06424
TC
1564 if ($req->user_can('edit_add_child', $parent)) {
1565 for my $name (@columns) {
1566 if (exists $data{$name} &&
1567 !$req->user_can("edit_add_field_$name", $parent)) {
1568 delete $data{$name};
1569 }
9168c88c
TC
1570 }
1571 }
39c06424
TC
1572 else {
1573 $parent_msg = "You cannot add a child to that article";
1574 $parent_code = "ACCESS";
1575 }
ca9aa2bf 1576 }
9168c88c 1577 else {
39c06424
TC
1578 if ($req->user_can('edit_add_child')) {
1579 for my $name (@columns) {
1580 if (exists $data{$name} &&
1581 !$req->user_can("edit_add_field_$name")) {
1582 delete $data{$name};
1583 }
9168c88c
TC
1584 }
1585 }
39c06424
TC
1586 else {
1587 $parent_msg = "You cannot create a top-level article";
1588 $parent_code = "ACCESS";
1589 }
1590 }
1591 if (!$parent_msg) {
1592 $self->validate_parent(\%data, $articles, $parent, \$parent_msg)
1593 or $parent_code = "PARENT";
1594 }
1595 if ($parent_msg) {
1596 if ($req->is_ajax) {
1597 return $req->json_content
1598 (
1599 success => 0,
1600 message => $parent_msg,
1601 error_code => $parent_code,
1602 errors => {},
1603 );
1604 }
1605 else {
1606 return $self->add_form($req, $articles, $parent_msg);
1607 }
9168c88c 1608 }
ca9aa2bf 1609
ca9aa2bf 1610 my $level = $parent ? $parent->{level}+1 : 1;
0ec4ac8a 1611 $data{level} = $level;
9168c88c 1612 $data{displayOrder} = time;
ca9aa2bf
TC
1613 $data{link} ||= '';
1614 $data{admin} ||= '';
ca9aa2bf 1615 $data{generator} = $self->generator;
41f10371 1616 $data{lastModified} = now_sqldatetime();
ca9aa2bf
TC
1617 $data{listed} = 1 unless defined $data{listed};
1618
9604a90c
TC
1619# Added by adrian
1620 $data{pageTitle} = '' unless defined $data{pageTitle};
1621 my $user = $req->getuser;
1622 $data{createdBy} = $user ? $user->{logon} : '';
1623 $data{lastModifiedBy} = $user ? $user->{logon} : '';
1624 $data{created} = now_sqldatetime();
12bcb7ac
TC
1625# end adrian
1626
efcc5a30
TC
1627 $data{force_dynamic} = 0;
1628 $data{cached_dynamic} = 0;
1629 $data{inherit_siteuser_rights} = 1;
9604a90c 1630
12bcb7ac
TC
1631# Added by adrian
1632 $data{metaDescription} = '' unless defined $data{metaDescription};
1633 $data{metaKeywords} = '' unless defined $data{metaKeywords};
1634# end adrian
1635
0ec4ac8a 1636 $self->fill_new_data($req, \%data, $articles);
8f88bb20 1637 for my $col (qw(titleImage imagePos template keyword menu titleAlias linkAlias body author summary)) {
0ec4ac8a
TC
1638 defined $data{$col}
1639 or $data{$col} = $self->default_value($req, \%data, $col);
1640 }
1641
c2096d67
TC
1642 for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1643 if ($req->user_can("edit_add_field_$col", $parent)
1644 && $cgi->param("save_$col")) {
1645 $data{$col} = $cgi->param($col) ? 1 : 0;
1646 }
1647 else {
1648 $data{$col} = $self->default_value($req, \%data, $col);
1649 }
1650 }
1651
8f88bb20
TC
1652 unless ($req->is_ajax) {
1653 for my $col (qw(release expire)) {
1654 $data{$col} = sql_date($data{$col});
1655 }
718a070d
TC
1656 }
1657
0ec4ac8a 1658 # these columns are handled a little differently
d7538448 1659 for my $col (qw(release expire threshold summaryLength )) {
0ec4ac8a
TC
1660 $data{$col}
1661 or $data{$col} = $self->default_value($req, \%data, $col);
1662 }
1663
ca9aa2bf
TC
1664 shift @columns;
1665 my $article = $table_object->add(@data{@columns});
1666
1667 # we now have an id - generate the links
1668
a319d280 1669 $article->update_dynamic($self->{cfg});
ca9aa2bf
TC
1670 my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
1671 $article->setAdmin("$cgi_uri/admin/admin.pl?id=$article->{id}");
1672 $article->setLink($self->make_link($article));
1673 $article->save();
1674
caa7299c
TC
1675 use Util 'generate_article';
1676 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
1677
8f88bb20
TC
1678 if ($req->is_ajax) {
1679 my $article_data = $article->data_only;
1680 $article_data->{images} = [];
1681 $article_data->{files} = [];
1682 $article_data->{link} = $article->link($req->cfg);
1683
1684 return $req->json_content
1685 (
1686 {
1687 success => 1,
1688 article => $self->_article_data($req, $article),
1689 },
1690 );
1691 }
1692
8b0b2f34
TC
1693 my $r = $cgi->param('r');
1694 if ($r) {
1695 $r .= ($r =~ /\?/) ? '&' : '?';
1696 $r .= "id=$article->{id}";
1697 }
1698 else {
41f10371
TC
1699
1700 $r = admin_base_url($req->cfg) . $article->{admin};
8b0b2f34
TC
1701 }
1702 return BSE::Template->get_refresh($r, $self->{cfg});
1703
ca9aa2bf
TC
1704}
1705
1706sub fill_old_data {
0d5ccc7f 1707 my ($self, $req, $article, $data) = @_;
ca9aa2bf 1708
4010d92e
TC
1709 if (exists $data->{body}) {
1710 $data->{body} =~ s/\x0D\x0A/\n/g;
1711 $data->{body} =~ tr/\r/\n/;
1712 }
ca9aa2bf 1713 for my $col (Article->columns) {
331fd099 1714 next if $col =~ /^custom/;
ca9aa2bf
TC
1715 $article->{$col} = $data->{$col}
1716 if exists $data->{$col} && $col ne 'id' && $col ne 'parentid';
1717 }
331fd099
TC
1718 custom_class($self->{cfg})
1719 ->article_fill_old($article, $data, $self->typename);
ca9aa2bf
TC
1720
1721 return 1;
1722}
1723
8f88bb20
TC
1724sub _article_data {
1725 my ($self, $req, $article) = @_;
1726
1727 my $article_data = $article->data_only;
1728 $article_data->{link} = $article->link($req->cfg);
1729 $article_data->{images} =
1730 [
1731 map $_->data_only, $article->images
1732 ];
1733 $article_data->{files} =
1734 [
1735 map $_->data_only, $article->files,
1736 ];
1737
1738 return $article_data;
1739}
1740
bf149413
TC
1741=item save
1742
1743Error codes:
1744
1745=over
1746
1747=item *
1748
1749ACCESS - user doesn't have access to this article.
1750
1751=item *
1752
1753LASTMOD - lastModified value doesn't match that in the article
1754
1755=item *
1756
1757PARENT - invalid parentid specified
1758
1759=back
1760
1761=cut
1762
ca9aa2bf
TC
1763sub save {
1764 my ($self, $req, $article, $articles) = @_;
4010d92e 1765
aa6896b6
TC
1766 $req->check_csrf("admin_save_article")
1767 or return $self->csrf_error($req, $article, "admin_save_article", "Save Article");
1768
4010d92e 1769 $req->user_can(edit_save => $article)
bf149413
TC
1770 or return $self->_service_error
1771 ($req, $article, $articles, "You don't have access to save this article",
1772 {}, "ACCESS");
efcc5a30
TC
1773
1774 my $old_dynamic = $article->is_dynamic;
ca9aa2bf
TC
1775 my $cgi = $req->cgi;
1776 my %data;
1777 for my $name ($article->columns) {
1778 $data{$name} = $cgi->param($name)
abf5bbc6
TC
1779 if defined($cgi->param($name)) and $name ne 'id' && $name ne 'parentid'
1780 && $req->user_can("edit_field_edit_$name", $article);
ca9aa2bf 1781 }
12b42a0b
TC
1782
1783# Added by adrian
1784# checks editor lastModified against record lastModified
1785 if ($self->{cfg}->entry('editor', 'check_modified')) {
1786 if ($article->{lastModified} ne $cgi->param('lastModified')) {
1787 my $whoModified = '';
1788 my $timeModified = ampm_time($article->{lastModified});
1789 if ($article->{lastModifiedBy}) {
1790 $whoModified = "by '$article->{lastModifiedBy}'";
1791 }
1792 print STDERR "non-matching lastModified, article not saved\n";
1793 my $msg = "Article changes not saved, this article was modified $whoModified at $timeModified since this editor was loaded";
bf149413 1794 return $self->_service_error($req, $article, $articles, $msg, {}, "LASTMOD");
12b42a0b
TC
1795 }
1796 }
1797# end adrian
1798
918735d1
TC
1799 # possibly this needs tighter error checking
1800 $data{flags} = join '', sort $cgi->param('flags')
1801 if $req->user_can("edit_field_edit_flags", $article);
ca9aa2bf 1802 my %errors;
bf149413
TC
1803 if (exists $article->{template} &&
1804 $article->{template} =~ m|\.\.|) {
1805 $errors{template} = "Please only select templates from the list provided";
1806 }
8f88bb20 1807 $self->validate_old($article, \%data, $articles, \%errors, scalar $req->is_ajax)
bf149413 1808 or return $self->_service_error($req, $article, $articles, undef, \%errors, "FIELD");
abf5bbc6
TC
1809 $self->save_thumbnail($cgi, $article, \%data)
1810 if $req->user_can('edit_field_edit_thumbImage', $article);
ca9aa2bf 1811 $self->fill_old_data($req, $article, \%data);
12b42a0b 1812
ca9aa2bf
TC
1813 # reparenting
1814 my $newparentid = $cgi->param('parentid');
abf5bbc6
TC
1815 if ($newparentid && $req->user_can('edit_field_edit_parentid', $article)) {
1816 if ($newparentid == $article->{parentid}) {
1817 # nothing to do
1818 }
1819 elsif ($newparentid != -1) {
1820 print STDERR "Reparenting...\n";
1821 my $newparent = $articles->getByPkey($newparentid);
1822 if ($newparent) {
1823 if ($newparent->{level} != $article->{level}-1) {
1824 # the article cannot become a child of itself or one of it's
1825 # children
1826 if ($article->{id} == $newparentid
1827 || $self->is_descendant($article->{id}, $newparentid, $articles)) {
1828 my $msg = "Cannot become a child of itself or of a descendant";
bf149413 1829 return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
abf5bbc6
TC
1830 }
1831 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
1832 if ($self->is_descendant($article->{id}, $shopid, $articles)) {
1833 my $msg = "Cannot become a descendant of the shop";
bf149413 1834 return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
abf5bbc6
TC
1835 }
1836 my $msg;
1837 $self->reparent($article, $newparentid, $articles, \$msg)
bf149413 1838 or return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
ca9aa2bf 1839 }
abf5bbc6
TC
1840 else {
1841 # stays at the same level, nothing special
1842 $article->{parentid} = $newparentid;
ca9aa2bf 1843 }
ca9aa2bf 1844 }
abf5bbc6
TC
1845 # else ignore it
1846 }
1847 else {
1848 # becoming a section
1849 my $msg;
1850 $self->reparent($article, -1, $articles, \$msg)
bf149413 1851 or return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
ca9aa2bf 1852 }
ca9aa2bf
TC
1853 }
1854
abf5bbc6 1855 $article->{listed} = $cgi->param('listed')
63e99d77 1856 if defined $cgi->param('listed') &&
abf5bbc6 1857 $req->user_can('edit_field_edit_listed', $article);
8f88bb20
TC
1858
1859 if ($req->user_can('edit_field_edit_release', $article)) {
1860 my $release = $cgi->param("release");
1861 if (defined $release && $release =~ /\S/) {
1862 if ($req->is_ajax) {
1863 $article->{release} = $release;
1864 }
1865 else {
1866 $article->{release} = sql_date($release)
1867 }
1868 }
1869 }
1870
abf5bbc6
TC
1871 $article->{expire} = sql_date($cgi->param('expire')) || $Constants::D_99
1872 if defined $cgi->param('expire') &&
1873 $req->user_can('edit_field_edit_expire', $article);
41f10371 1874 $article->{lastModified} = now_sqldatetime();
c2096d67
TC
1875 for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1876 if ($req->user_can("edit_field_edit_$col", $article)
1877 && $cgi->param("save_$col")) {
1878 $article->{$col} = $cgi->param($col) ? 1 : 0;
1879 }
1880 }
1881
1882# Added by adrian
1883 my $user = $req->getuser;
1884 $article->{lastModifiedBy} = $user ? $user->{logon} : '';
1885# end adrian
1886
1887 my @save_group_ids = $cgi->param('save_group_id');
1888 if ($req->user_can('edit_field_edit_group_id')
1889 && @save_group_ids) {
1890 require BSE::TB::SiteUserGroups;
1891 my %groups = map { $_->{id} => $_ }
1892 BSE::TB::SiteUserGroups->admin_and_query_groups($self->{cfg});
1893 my %set = map { $_ => 1 } $cgi->param('group_id');
1894 my %current = map { $_ => 1 } $article->group_ids;
1895
1896 for my $group_id (@save_group_ids) {
1897 $groups{$group_id} or next;
1898 if ($current{$group_id} && !$set{$group_id}) {
1899 $article->remove_group_id($group_id);
1900 }
1901 elsif (!$current{$group_id} && $set{$group_id}) {
1902 $article->add_group_id($group_id);
1903 }
1904 }
efcc5a30
TC
1905 }
1906
63e99d77 1907 my $old_link = $article->{link};
efcc5a30
TC
1908 # this need to go last
1909 $article->update_dynamic($self->{cfg});
95989433
TC
1910 if ($article->{link} &&
1911 !$self->{cfg}->entry('protect link', $article->{id})) {
1912 my $article_uri = $self->make_link($article);
95989433 1913 $article->setLink($article_uri);
ca9aa2bf
TC
1914 }
1915
1916 $article->save();
caa7299c 1917
63e99d77 1918 # fix the kids too
efcc5a30 1919 my @extra_regen;
63e99d77
TC
1920 @extra_regen = $self->update_child_dynamic($article, $articles, $req);
1921
1922 if ($article->is_dynamic || $old_dynamic) {
1923 if (!$old_dynamic and $old_link) {
1924 unlink $article->link_to_filename($self->{cfg}, $old_link);
1925 }
16901a2a
TC
1926 elsif (!$article->is_dynamic) {
1927 unlink $article->cached_filename($self->{cfg});
1928 }
efcc5a30
TC
1929 }
1930
caa7299c 1931 use Util 'generate_article';
efcc5a30
TC
1932 if ($Constants::AUTO_GENERATE) {
1933 generate_article($articles, $article);
1934 for my $regen_id (@extra_regen) {
1935 my $regen = $articles->getByPkey($regen_id);
63e99d77 1936 Util::generate_low($articles, $regen, $self->{cfg});
efcc5a30
TC
1937 }
1938 }
caa7299c 1939
8f88bb20
TC
1940 if ($req->is_ajax) {
1941 return $req->json_content
1942 (
1943 {
1944 success => 1,
1945 article => $self->_article_data($req, $article),
1946 },
1947 );
1948 }
1949
8b0b2f34 1950 return $self->refresh($article, $cgi, undef, 'Article saved');
ca9aa2bf
TC
1951}
1952
efcc5a30
TC
1953sub update_child_dynamic {
1954 my ($self, $article, $articles, $req) = @_;
1955
1956 my $cfg = $req->cfg;
1957 my @stack = $article->children;
1958 my @regen;
1959 while (@stack) {
1960 my $workart = pop @stack;
1961 my $old_dynamic = $workart->is_dynamic; # before update
63e99d77 1962 my $old_link = $workart->{link};
3e37b5ba
TC
1963 my $editor;
1964 ($editor, $workart) = $self->article_class($workart, $articles, $cfg);
1965
efcc5a30
TC
1966 $workart->update_dynamic($cfg);
1967 if ($old_dynamic != $workart->is_dynamic) {
1968 # update the link
1969 if ($article->{link} && !$cfg->entry('protect link', $workart->{id})) {
efcc5a30
TC
1970 my $uri = $editor->make_link($workart);
1971 $workart->setLink($uri);
63e99d77 1972
8f84f3f1
TC
1973 !$old_dynamic && $old_link
1974 and unlink $workart->link_to_filename($cfg, $old_link);
1975 $workart->is_dynamic
16901a2a 1976 or unlink $workart->cached_filename($cfg);
efcc5a30
TC
1977 }
1978
1979 # save dynamic cache change and link if that changed
1980 $workart->save;
1981 }
1982 push @stack, $workart->children;
1983 push @regen, $workart->{id};
1984 }
1985
1986 @regen;
1987}
1988
ca9aa2bf
TC
1989sub sql_date {
1990 my $str = shift;
1991 my ($year, $month, $day);
1992
1993 # look for a date
1994 if (($day, $month, $year) = ($str =~ m!(\d+)/(\d+)/(\d+)!)) {
1995 $year += 2000 if $year < 100;
1996
1997 return sprintf("%04d-%02d-%02d", $year, $month, $day);
1998 }
1999 return undef;
2000}
2001
12b42a0b
TC
2002# Added by adrian
2003# Converts 24hr time to 12hr AM/PM time
2004sub ampm_time {
2005 my $str = shift;
2006 my ($hour, $minute, $second, $ampm);
2007
2008 # look for a time
2009 if (($hour, $minute, $second) = ($str =~ m!(\d+):(\d+):(\d+)!)) {
2010 if ($hour > 12) {
2011 $hour -= 12;
2012 $ampm = 'PM';
2013 }
2014 else {
c2096d67 2015 $hour = 12 if $hour == 0;
12b42a0b
TC
2016 $ampm = 'AM';
2017 }
2018 return sprintf("%02d:%02d:%02d $ampm", $hour, $minute, $second);
2019 }
2020 return undef;
2021}
2022# end adrian
2023
ca9aa2bf
TC
2024sub reparent {
2025 my ($self, $article, $newparentid, $articles, $rmsg) = @_;
2026
2027 my $newlevel;
2028 if ($newparentid == -1) {
2029 $newlevel = 1;
2030 }
2031 else {
2032 my $parent = $articles->getByPkey($newparentid);
2033 unless ($parent) {
2034 $$rmsg = "Cannot get new parent article";
2035 return;
2036 }
2037 $newlevel = $parent->{level} + 1;
2038 }
2039 # the caller will save this one
2040 $article->{parentid} = $newparentid;
2041 $article->{level} = $newlevel;
2042 $article->{displayOrder} = time;
2043
2044 my @change = ( [ $article->{id}, $newlevel ] );
2045 while (@change) {
2046 my $this = shift @change;
2047 my ($art, $level) = @$this;
2048
2049 my @kids = $articles->getBy(parentid=>$art);
2050 push @change, map { [ $_->{id}, $level+1 ] } @kids;
2051
2052 for my $kid (@kids) {
2053 $kid->{level} = $level+1;
2054 $kid->save;
2055 }
2056 }
2057
2058 return 1;
2059}
2060
2061# tests if $desc is a descendant of $art
2062# where both are article ids
2063sub is_descendant {
2064 my ($self, $art, $desc, $articles) = @_;
2065
2066 my @check = ($art);
2067 while (@check) {
2068 my $parent = shift @check;
2069 $parent == $desc and return 1;
2070 my @kids = $articles->getBy(parentid=>$parent);
2071 push @check, map $_->{id}, @kids;
2072 }
2073
2074 return 0;
2075}
2076
2077sub save_thumbnail {
2078 my ($self, $cgi, $original, $newdata) = @_;
2079
2080 unless ($original) {
2081 @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2082 }
ab2cd916 2083 my $imagedir = cfg_image_dir($self->{cfg});
ca9aa2bf
TC
2084 if ($cgi->param('remove_thumb') && $original && $original->{thumbImage}) {
2085 unlink("$imagedir/$original->{thumbImage}");
2086 @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2087 }
2088 my $image = $cgi->param('thumbnail');
2089 if ($image && -s $image) {
2090 # where to put it...
2091 my $name = '';
2092 $image =~ /([\w.-]+)$/ and $name = $1;
2093 my $filename = time . "_" . $name;
2094
2095 use Fcntl;
2096 my $counter = "";
2097 $filename = time . '_' . $counter . '_' . $name
2098 until sysopen( OUTPUT, "$imagedir/$filename",
2099 O_WRONLY| O_CREAT| O_EXCL)
2100 || ++$counter > 100;
2101
2102 fileno(OUTPUT) or die "Could not open image file: $!";
2103 binmode OUTPUT;
2104 my $buffer;
2105
2106 #no strict 'refs';
2107
2108 # read the image in from the browser and output it to our
2109 # output filehandle
2110 print STDERR "\$image ",ref $image,"\n";
2111 seek $image, 0, 0;
2112 print OUTPUT $buffer while sysread $image, $buffer, 1024;
2113
2114 close OUTPUT
2115 or die "Could not close image output file: $!";
2116
2117 use Image::Size;
2118
2119 if ($original && $original->{thumbImage}) {
2120 #unlink("$imagedir/$original->{thumbImage}");
2121 }
2122 @$newdata{qw/thumbWidth thumbHeight/} = imgsize("$imagedir/$filename");
2123 $newdata->{thumbImage} = $filename;
2124 }
2125}
2126
2127sub child_types {
2128 my ($self, $article) = @_;
2129
2130 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2131 if ($article && $article->{id} && $article->{id} == $shopid) {
2132 return ( 'BSE::Edit::Catalog' );
2133 }
2134 return ( 'BSE::Edit::Article' );
2135}
2136
2137sub add_stepkid {
2138 my ($self, $req, $article, $articles) = @_;
2139
aa6896b6
TC
2140 $req->check_csrf("admin_add_stepkid")
2141 or return $self->csrf_error($req, $article, "admin_add_stepkid", "Add Stepkid");
2142
31a26b52
TC
2143 $req->user_can(edit_stepkid_add => $article)
2144 or return $self->edit_form($req, $article, $articles,
2145 "You don't have access to add step children to this article");
2146
ca9aa2bf
TC
2147 my $cgi = $req->cgi;
2148 require 'BSE/Admin/StepParents.pm';
2149 eval {
2150 my $childId = $cgi->param('stepkid');
2151 defined $childId
2152 or die "No stepkid supplied to add_stepkid";
2153 $childId =~ /^\d+$/
2154 or die "Invalid stepkid supplied to add_stepkid";
2155 my $child = $articles->getByPkey($childId)
2156 or die "Article $childId not found";
31a26b52
TC
2157
2158 $req->user_can(edit_stepparent_add => $child)
2159 or die "You don't have access to add a stepparent to that article\n";
ca9aa2bf 2160
ca9aa2bf 2161 my $release = $cgi->param('release');
8f88bb20 2162 dh_parse_date($release) or $release = undef;
ca9aa2bf 2163 my $expire = $cgi->param('expire');
8f88bb20 2164 dh_parse_date($expire) or $expire = undef;
ca9aa2bf
TC
2165
2166 my $newentry =
2167 BSE::Admin::StepParents->add($article, $child, $release, $expire);
2168 };
2169 if ($@) {
2170 return $self->edit_form($req, $article, $articles, $@);
2171 }
a0a8147b
TC
2172
2173 use Util 'generate_article';
2174 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2175
8b0b2f34 2176 return $self->refresh($article, $cgi, 'step', 'Stepchild added');
ca9aa2bf
TC
2177}
2178
2179sub del_stepkid {
2180 my ($self, $req, $article, $articles) = @_;
2181
aa6896b6
TC
2182 $req->check_csrf("admin_remove_stepkid")
2183 or return $self->csrf_error($req, $article, "admin_del_stepkid", "Delete Stepkid");
31a26b52
TC
2184 $req->user_can(edit_stepkid_delete => $article)
2185 or return $self->edit_form($req, $article, $articles,
2186 "You don't have access to delete stepchildren from this article");
2187
ca9aa2bf
TC
2188 my $cgi = $req->cgi;
2189 require 'BSE/Admin/StepParents.pm';
2190 eval {
2191 my $childId = $cgi->param('stepkid');
2192 defined $childId
2193 or die "No stepkid supplied to add_stepkid";
2194 $childId =~ /^\d+$/
2195 or die "Invalid stepkid supplied to add_stepkid";
2196 my $child = $articles->getByPkey($childId)
2197 or die "Article $childId not found";
31a26b52
TC
2198
2199 $req->user_can(edit_stepparent_delete => $child)
2200 or die "You cannot remove stepparents from that article\n";
ca9aa2bf
TC
2201
2202 BSE::Admin::StepParents->del($article, $child);
2203 };
2204
2205 if ($@) {
2206 return $self->edit_form($req, $article, $articles, $@);
2207 }
a0a8147b
TC
2208 use Util 'generate_article';
2209 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2210
8b0b2f34 2211 return $self->refresh($article, $cgi, 'step', 'Stepchild deleted');
ca9aa2bf
TC
2212}
2213
2214sub save_stepkids {
2215 my ($self, $req, $article, $articles) = @_;
2216
aa6896b6
TC
2217 $req->check_csrf("admin_save_stepkids")
2218 or return $self->csrf_error($req, $article, "admin_save_stepkids", "Save Stepkids");
2219
31a26b52
TC
2220 $req->user_can(edit_stepkid_save => $article)
2221 or return $self->edit_form($req, $article, $articles,
2222 "No access to save stepkid data for this article");
2223
ca9aa2bf
TC
2224 my $cgi = $req->cgi;
2225 require 'BSE/Admin/StepParents.pm';
2226 my @stepcats = OtherParents->getBy(parentId=>$article->{id});
2227 my %stepcats = map { $_->{parentId}, $_ } @stepcats;
2228 my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2229 for my $stepcat (@stepcats) {
31a26b52
TC
2230 $req->user_can(edit_stepparent_save => $stepcat->{childId})
2231 or next;
ca9aa2bf
TC
2232 for my $name (qw/release expire/) {
2233 my $date = $cgi->param($name.'_'.$stepcat->{childId});
2234 if (defined $date) {
2235 if ($date eq '') {
2236 $date = $datedefs{$name};
2237 }
8f88bb20 2238 elsif (dh_parse_date($date)) {
ca9aa2bf
TC
2239 use BSE::Util::SQL qw/date_to_sql/;
2240 $date = date_to_sql($date);
2241 }
2242 else {
2243 return $self->refresh($article, $cgi, '', "Invalid date '$date'");
2244 }
2245 $stepcat->{$name} = $date;
2246 }
2247 }
2248 eval {
2249 $stepcat->save();
2250 };
2251 $@ and return $self->refresh($article, $cgi, '', $@);
2252 }
a0a8147b
TC
2253 use Util 'generate_article';
2254 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2255
8b0b2f34 2256 return $self->refresh($article, $cgi, 'step', 'Stepchild information saved');
ca9aa2bf
TC
2257}
2258
2259sub add_stepparent {
2260 my ($self, $req, $article, $articles) = @_;
2261
aa6896b6
TC
2262 $req->check_csrf("admin_add_stepparent")
2263 or return $self->csrf_error($req, $article, "admin_add_stepparent", "Add Stepparent");
2264
31a26b52
TC
2265 $req->user_can(edit_stepparent_add => $article)
2266 or return $self->edit_form($req, $article, $articles,
2267 "You don't have access to add stepparents to this article");
2268
ca9aa2bf
TC
2269 my $cgi = $req->cgi;
2270 require 'BSE/Admin/StepParents.pm';
2271 eval {
2272 my $step_parent_id = $cgi->param('stepparent');
2273 defined($step_parent_id)
2274 or die "No stepparent supplied to add_stepparent";
2275 int($step_parent_id) eq $step_parent_id
2276 or die "Invalid stepcat supplied to add_stepcat";
2277 my $step_parent = $articles->getByPkey($step_parent_id)
31a26b52
TC
2278 or die "Parent $step_parent_id not found\n";
2279
2280 $req->user_can(edit_stepkid_add => $step_parent)
2281 or die "You don't have access to add a stepkid to that article\n";
ca9aa2bf
TC
2282
2283 my $release = $cgi->param('release');
2284 defined $release
2285 or $release = "01/01/2000";
8f88bb20 2286 $release eq '' or dh_parse_date($release)
ca9aa2bf
TC
2287 or die "Invalid release date";
2288 my $expire = $cgi->param('expire');
2289 defined $expire
2290 or $expire = '31/12/2999';
8f88bb20 2291 $expire eq '' or dh_parse_date($expire)
ca9aa2bf
TC
2292 or die "Invalid expire data";
2293
2294 my $newentry =
2295 BSE::Admin::StepParents->add($step_parent, $article, $release, $expire);
2296 };
2297 $@ and return $self->refresh($article, $cgi, 'step', $@);
2298
a0a8147b
TC
2299 use Util 'generate_article';
2300 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2301
8b0b2f34 2302 return $self->refresh($article, $cgi, 'stepparents', 'Stepparent added');
ca9aa2bf
TC
2303}
2304
2305sub del_stepparent {
2306 my ($self, $req, $article, $articles) = @_;
2307
aa6896b6
TC
2308 $req->check_csrf("admin_remove_stepparent")
2309 or return $self->csrf_error($req, $article, "admin_del_stepparent", "Delete Stepparent");
2310
31a26b52
TC
2311 $req->user_can(edit_stepparent_delete => $article)
2312 or return $self->edit_form($req, $article, $articles,
2313 "You cannot remove stepparents from that article");
2314
ca9aa2bf
TC
2315 my $cgi = $req->cgi;
2316 require 'BSE/Admin/StepParents.pm';
2317 my $step_parent_id = $cgi->param('stepparent');
2318 defined($step_parent_id)
2319 or return $self->refresh($article, $cgi, 'stepparents',
2320 "No stepparent supplied to add_stepcat");
2321 int($step_parent_id) eq $step_parent_id
2322 or return $self->refresh($article, $cgi, 'stepparents',
2323 "Invalid stepparent supplied to add_stepparent");
2324 my $step_parent = $articles->getByPkey($step_parent_id)
2325 or return $self->refresh($article, $cgi, 'stepparent',
2326 "Stepparent $step_parent_id not found");
2327
31a26b52
TC
2328 $req->user_can(edit_stepkid_delete => $step_parent)
2329 or die "You don't have access to remove the stepkid from that article\n";
2330
ca9aa2bf
TC
2331 eval {
2332 BSE::Admin::StepParents->del($step_parent, $article);
2333 };
2334 $@ and return $self->refresh($article, $cgi, 'stepparents', $@);
2335
a0a8147b
TC
2336 use Util 'generate_article';
2337 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2338
8b0b2f34 2339 return $self->refresh($article, $cgi, 'stepparents', 'Stepparent deleted');
ca9aa2bf
TC
2340}
2341
2342sub save_stepparents {
2343 my ($self, $req, $article, $articles) = @_;
2344
aa6896b6
TC
2345 $req->check_csrf("admin_save_stepparents")
2346 or return $self->csrf_error($req, $article, "admin_save_stepparents", "Save Stepparents");
31a26b52
TC
2347 $req->user_can(edit_stepparent_save => $article)
2348 or return $self->edit_form($req, $article, $articles,
2349 "No access to save stepparent data for this artice");
2350
ca9aa2bf
TC
2351 my $cgi = $req->cgi;
2352
2353 require 'BSE/Admin/StepParents.pm';
2354 my @stepparents = OtherParents->getBy(childId=>$article->{id});
2355 my %stepparents = map { $_->{parentId}, $_ } @stepparents;
2356 my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2357 for my $stepparent (@stepparents) {
31a26b52
TC
2358 $req->user_can(edit_stepkid_save => $stepparent->{parentId})
2359 or next;
ca9aa2bf
TC
2360 for my $name (qw/release expire/) {
2361 my $date = $cgi->param($name.'_'.$stepparent->{parentId});
2362 if (defined $date) {
2363 if ($date eq '') {
2364 $date = $datedefs{$name};
2365 }
8f88bb20 2366 elsif (dh_parse_date($date)) {
ca9aa2bf
TC
2367 use BSE::Util::SQL qw/date_to_sql/;
2368 $date = date_to_sql($date);
2369 }
2370 else {
2371 return $self->refresh($article, $cgi, "Invalid date '$date'");
2372 }
2373 $stepparent->{$name} = $date;
2374 }
2375 }
2376 eval {
2377 $stepparent->save();
2378 };
2379 $@ and return $self->refresh($article, $cgi, '', $@);
2380 }
2381
a0a8147b
TC
2382 use Util 'generate_article';
2383 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2384
8b0b2f34
TC
2385 return $self->refresh($article, $cgi, 'stepparents',
2386 'Stepparent information saved');
ca9aa2bf
TC
2387}
2388
58baa27b 2389sub refresh_url {
ca9aa2bf
TC
2390 my ($self, $article, $cgi, $name, $message, $extras) = @_;
2391
8b0b2f34 2392 my $url = $cgi->param('r');
16ac5598
TC
2393 if ($url) {
2394 if ($url !~ /[?&](m|message)=/ && $message) {
2395 # add in messages if none in the provided refresh
2396 my @msgs = ref $message ? @$message : $message;
f3fc60c0 2397 my $sep = $url =~ /\?/ ? "&" : "?";
16ac5598 2398 for my $msg (@msgs) {
f3fc60c0 2399 $url .= $sep . "m=" . CGI::escape($msg);
16ac5598
TC
2400 }
2401 }
2402 }
2403 else {
41f10371 2404 my $urlbase = admin_base_url($self->{cfg});
8b0b2f34 2405 $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
16ac5598
TC
2406 if ($message) {
2407 my @msgs = ref $message ? @$message : $message;
2408 for my $msg (@msgs) {
2409 $url .= "&m=" . CGI::escape($msg);
2410 }
2411 }
8b0b2f34
TC
2412 if ($cgi->param('_t')) {
2413 $url .= "&_t=".CGI::escape($cgi->param('_t'));
2414 }
2415 $url .= $extras if defined $extras;
2416 my $cgiextras = $cgi->param('e');
2417 $url .= "#$name" if $name;
ca9aa2bf 2418 }
ca9aa2bf 2419
58baa27b
TC
2420 return $url;
2421}
2422
2423sub refresh {
2424 my ($self, $article, $cgi, $name, $message, $extras) = @_;
2425
2426 my $url = $self->refresh_url($article, $cgi, $name, $message, $extras);
2427
ca9aa2bf
TC
2428 return BSE::Template->get_refresh($url, $self->{cfg});
2429}
2430
2431sub show_images {
918735d1 2432 my ($self, $req, $article, $articles, $msg, $errors) = @_;
ca9aa2bf
TC
2433
2434 my %acts;
918735d1 2435 %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
2436 my $template = 'admin/article_img';
2437
4d764c34 2438 return $req->dyn_response($template, \%acts);
ca9aa2bf
TC
2439}
2440
2441sub save_image_changes {
2442 my ($self, $req, $article, $articles) = @_;
2443
aa6896b6
TC
2444 $req->check_csrf("admin_save_images")
2445 or return $self->csrf_error($req, $article, "admin_save_images", "Save Images");
2446
abf5bbc6 2447 $req->user_can(edit_images_save => $article)
cc9019d1 2448 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2449 "You don't have access to save image information for this article");
2450
b95fc3a0
TC
2451 my $image_dir = cfg_image_dir($req->cfg);
2452
ca9aa2bf
TC
2453 my $cgi = $req->cgi;
2454 my $image_pos = $cgi->param('imagePos');
2455 if ($image_pos
2456 && $image_pos =~ /^(?:tl|tr|bl|br)$/
2457 && $image_pos ne $article->{imagePos}) {
2458 $article->{imagePos} = $image_pos;
2459 $article->save;
2460 }
daee3409 2461 my @images = $self->get_images($article);
4772671f
TC
2462
2463 @images or
2464 return $self->refresh($article, $cgi, undef, 'No images to save information for');
ca9aa2bf 2465
b95fc3a0
TC
2466 my %changes;
2467 my %errors;
2468 my %names;
e63c3728 2469 my %old_images;
8326f275 2470 my @new_images;
b95fc3a0
TC
2471 for my $image (@images) {
2472 my $id = $image->{id};
2473
2474 my $alt = $cgi->param("alt$id");
2475 if ($alt ne $image->{alt}) {
2476 $changes{$id}{alt} = $alt;
ca9aa2bf 2477 }
b95fc3a0
TC
2478
2479 my $url = $cgi->param("url$id");
2480 if (defined $url && $url ne $image->{url}) {
2481 $changes{$id}{url} = $url;
ca9aa2bf 2482 }
b95fc3a0
TC
2483
2484 my $name = $cgi->param("name$id");
2485 if (defined $name && $name ne $image->{name}) {
547a26ad
TC
2486 if ($name eq '') {
2487 if ($article->{id} > 0) {
2488 $changes{$id}{name} = '';
2489 }
2490 else {
2491 $errors{"name$id"} = "Identifiers are required for global images";
2492 }
2d83755d
TC
2493 }
2494 elsif ($name =~ /^[a-z_]\w*$/i) {
b95fc3a0
TC
2495 my $msg;
2496 if ($self->validate_image_name($name, \$msg)) {
2497 # check for duplicates after the loop
2498 push @{$names{lc $name}}, $image->{id}
2499 if length $name;
2500 $changes{$id}{name} = $name;
4772671f
TC
2501 }
2502 else {
b95fc3a0 2503 $errors{"name$id"} = $msg;
4772671f
TC
2504 }
2505 }
b95fc3a0
TC
2506 else {
2507 $errors{"name$id"} = 'Image name must be empty or alphanumeric and unique to the article';
2508 }
2509 }
2510 else {
2511 push @{$names{lc $image->{name}}}, $image->{id}
2512 if length $image->{name};
2513 }
2514
2515 my $filename = $cgi->param("image$id");
2516 if (defined $filename && length $filename) {
2517 my $in_fh = $cgi->upload("image$id");
2518 if ($in_fh) {
2519 # work out where to put it
2520 require DevHelp::FileUpload;
daee3409 2521 my $msg;
b95fc3a0
TC
2522 my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
2523 ($image_dir, $filename . '', \$msg);
2524 if ($image_name) {
2525 local $/ = \8192;
2526 my $data;
2527 while ($data = <$in_fh>) {
2528 print $out_fh $data;
2529 }
2530 close $out_fh;
2531
2532 my $full_filename = "$image_dir/$image_name";
2533 require Image::Size;
2534 my ($width, $height, $type) = Image::Size::imgsize($full_filename);
2535 if ($width) {
e63c3728
TC
2536 $old_images{$id} =
2537 {
2538 image => $image->{image},
2539 storage => $image->{storage}
2540 };
8326f275
TC
2541 push @new_images, $image_name;
2542
b95fc3a0 2543 $changes{$id}{image} = $image_name;
e63c3728
TC
2544 $changes{$id}{storage} = 'local';
2545 $changes{$id}{src} = "/images/$image_name";
b95fc3a0
TC
2546 $changes{$id}{width} = $width;
2547 $changes{$id}{height} = $height;
5d1b1cbb 2548 $changes{$id}{ftype} = $self->_image_ftype($type);
b95fc3a0
TC
2549 }
2550 else {
2551 $errors{"image$id"} = $type;
2552 }
2553 }
2554 else {
2555 $errors{"image$id"} = $msg;
2556 }
2557 }
2558 else {
2559 # problem uploading
2560 $errors{"image$id"} = "No image file received";
2561 }
2562 }
2563 }
2564 # look for duplicate names
2565 for my $name (keys %names) {
2566 if (@{$names{$name}} > 1) {
2567 for my $id (@{$names{$name}}) {
2568 $errors{"name$id"} = 'Image name must be unique to the article';
daee3409 2569 }
4772671f
TC
2570 }
2571 }
8326f275
TC
2572 if (keys %errors) {
2573 # remove files that won't be stored because validation failed
2574 unlink map "$image_dir/$_", @new_images;
2575
2576 return $self->edit_form($req, $article, $articles, undef,
2577 \%errors);
2578 }
b95fc3a0 2579
e63c3728
TC
2580 my $mgr = $self->_image_manager($req->cfg);
2581 $req->flash('Image information saved');
2582 my $changes_found = 0;
2583 my $auto_store = $cgi->param('auto_storage');
2584 for my $image (@images) {
2585 my $id = $image->{id};
2586
2587 if ($changes{$id}) {
2588 my $changes = $changes{$id};
2589 ++$changes_found;
2590
2591 for my $field (keys %$changes) {
2592 $image->{$field} = $changes->{$field};
b95fc3a0 2593 }
ca9aa2bf
TC
2594 $image->save;
2595 }
a0a8147b 2596
e63c3728
TC
2597 my $old_storage = $image->{storage};
2598 my $new_storage = $auto_store ? '' : $cgi->param("storage$id");
2599 defined $new_storage or $new_storage = $image->{storage};
2600 $new_storage = $mgr->select_store($image->{image}, $new_storage, $image);
2601 if ($new_storage ne $old_storage) {
2602 eval {
2603 $image->{src} = $mgr->store($image->{image}, $new_storage, $image);
2604 $image->{storage} = $new_storage;
2605 $image->save;
2606 };
2607
2608 if ($old_storage ne 'local') {
2609 $mgr->unstore($image->{image}, $old_storage);
2610 }
2611 }
2612 }
2613
2614 # delete any image files that were replaced
2615 for my $old_image (values %old_images) {
2616 my ($image, $storage) = @$old_image{qw/image storage/};
2617 if ($storage ne 'local') {
2618 $mgr->unstore($image->{image}, $storage);
2619 }
2620 unlink "$image_dir/$image";
2621 }
2622
2623 if ($changes_found) {
b95fc3a0
TC
2624 use Util 'generate_article';
2625 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2626 }
e63c3728
TC
2627
2628 return $self->refresh($article, $cgi);
ca9aa2bf
TC
2629}
2630
58baa27b
TC
2631=item _service_error
2632
2633This function is called on various errors.
2634
2635If a _service parameter was supplied, returns text like:
2636
2637=over
2638
2639Result: failure
2640
2641Field-Error: I<field-name1> - I<message1>
2642
2643Field-Error: I<field-name2> - I<message2>
2644
2645=back
2646
2647If the request is detected as an ajax request or a _ parameter is
2648supplied, return JSON like:
2649
2650 { error: I<message> }
2651
2652Otherwise display the normal edit page with the error.
2653
2654=cut
2655
dbcd12e5 2656sub _service_error {
60bc6601 2657 my ($self, $req, $article, $articles, $msg, $error, $code) = @_;
dbcd12e5 2658
f3fc60c0
TC
2659 unless ($article) {
2660 my $mymsg;
2661 $article = $self->_dummy_article($req, $articles, \$mymsg);
2662 $article ||=
2663 {
2664 map $_ => '', Article->columns
2665 };
2666 }
2667
dbcd12e5
TC
2668 if ($req->cgi->param('_service')) {
2669 my $body = '';
2670 $body .= "Result: failure\n";
2671 if (ref $error) {
2672 for my $field (keys %$error) {
2673 my $text = $error->{$field};
2674 $text =~ tr/\n/ /;
2675 $body .= "Field-Error: $field - $text\n";
2676 }
2677 my $text = join ('/', values %$error);
2678 $text =~ tr/\n/ /;
2679 $body .= "Error: $text\n";
2680 }
58baa27b
TC
2681 elsif ($msg) {
2682 $body .= "Error: $msg\n";
2683 }
dbcd12e5
TC
2684 else {
2685 $body .= "Error: $error\n";
2686 }
2687 return
2688 {
2689 type => 'text/plain',
2690 content => $body,
2691 };
2692 }
58baa27b
TC
2693 elsif ((() = $req->cgi->param('_')) ||
2694 (defined $ENV{HTTP_X_REQUESTED_WITH}
2695 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/)) {
9b3a5df0
TC
2696 $error ||= {};
2697 my $result = { errors => $error };
2698 $msg and $result->{message} = $msg;
60bc6601 2699 $code and $result->{error_code} = $code;
9b3a5df0 2700 return $req->json_content($result);
58baa27b 2701 }
dbcd12e5 2702 else {
bf87e97c 2703 return $self->edit_form($req, $article, $articles, $msg, $error);
dbcd12e5
TC
2704 }
2705}
2706
2707sub _service_success {
2708 my ($self, $results) = @_;
2709
2710 my $body = "Result: success\n";
2711 for my $field (keys %$results) {
2712 $body .= "$field: $results->{$field}\n";
2713 }
2714 return
2715 {
2716 type => 'text/plain',
2717 content => $body,
2718 };
2719}
2720
5d1b1cbb
TC
2721sub _image_ftype {
2722 my ($self, $type) = @_;
2723
2724 if ($type eq 'CWS' || $type eq 'SWF') {
2725 return "flash";
2726 }
2727
2728 return "img";
2729}
2730
bf87e97c
TC
2731sub do_add_image {
2732 my ($self, $cfg, $article, $image, %opts) = @_;
ca9aa2bf 2733
bf87e97c
TC
2734 my $errors = $opts{errors}
2735 or die "No errors parameter";
ca9aa2bf 2736
bf87e97c 2737 my $imageref = $opts{name};
d794b180 2738 if (defined $imageref && $imageref ne '') {
4772671f
TC
2739 if ($imageref =~ /^[a-z_]\w+$/i) {
2740 # make sure it's unique
daee3409 2741 my @images = $self->get_images($article);
4772671f
TC
2742 for my $img (@images) {
2743 if (defined $img->{name} && lc $img->{name} eq lc $imageref) {
bf87e97c 2744 $errors->{name} = 'Image name must be unique to the article';
4772671f
TC
2745 last;
2746 }
2747 }
2748 }
2749 else {
bf87e97c 2750 $errors->{name} = 'Image name must be empty or alphanumeric beginning with an alpha character';
4772671f
TC
2751 }
2752 }
2753 else {
2754 $imageref = '';
2755 }
bf87e97c 2756 unless ($errors->{name}) {
d09682dd
TC
2757 my $workmsg;
2758 $self->validate_image_name($imageref, \$workmsg)
bf87e97c 2759 or $errors->{name} = $workmsg;
daee3409 2760 }
4772671f 2761
4772671f
TC
2762 if ($image) {
2763 if (-z $image) {
bf87e97c 2764 $errors->{image} = 'Image file is empty';
4772671f 2765 }
ca9aa2bf 2766 }
4772671f 2767 else {
bf87e97c 2768 $errors->{image} = 'Please enter an image filename';
ca9aa2bf 2769 }
bf87e97c
TC
2770 keys %$errors
2771 and return;
4772671f 2772
bf87e97c 2773 my $imagename = $opts{filename} || $image;
ca9aa2bf
TC
2774 $imagename .= ''; # force it into a string
2775 my $basename = '';
bf87e97c 2776 $imagename =~ tr/ //d;
ca9aa2bf
TC
2777 $imagename =~ /([\w.-]+)$/ and $basename = $1;
2778
2779 # create a filename that we hope is unique
2780 my $filename = time. '_'. $basename;
2781
2782 # for the sysopen() constants
2783 use Fcntl;
2784
bf87e97c 2785 my $imagedir = cfg_image_dir($cfg);
ca9aa2bf
TC
2786 # loop until we have a unique filename
2787 my $counter="";
2788 $filename = time. '_' . $counter . '_' . $basename
2789 until sysopen( OUTPUT, "$imagedir/$filename", O_WRONLY| O_CREAT| O_EXCL)
2790 || ++$counter > 100;
2791
2792 fileno(OUTPUT) or die "Could not open image file: $!";
2793
2794 # for OSs with special text line endings
2795 binmode OUTPUT;
2796
2797 my $buffer;
2798
2799 no strict 'refs';
2800
2801 # read the image in from the browser and output it to our output filehandle
2802 print OUTPUT $buffer while read $image, $buffer, 1024;
2803
2804 # close and flush
2805 close OUTPUT
2806 or die "Could not close image file $filename: $!";
2807
2808 use Image::Size;
2809
2810
f40af7e2 2811 my($width,$height, $type) = imgsize("$imagedir/$filename");
ca9aa2bf 2812
bf87e97c 2813 my $alt = $opts{alt};
ca9aa2bf 2814 defined $alt or $alt = '';
bf87e97c 2815 my $url = $opts{url};
ca9aa2bf
TC
2816 defined $url or $url = '';
2817 my %image =
2818 (
2819 articleId => $article->{id},
2820 image => $filename,
2821 alt=>$alt,
2822 width=>$width,
2823 height => $height,
2824 url => $url,
2825 displayOrder=>time,
4772671f 2826 name => $imageref,
e63c3728
TC
2827 storage => 'local',
2828 src => '/images/' . $filename,
5d1b1cbb 2829 ftype => $self->_image_ftype($type),
ca9aa2bf 2830 );
f40af7e2
TC
2831 require BSE::TB::Images;
2832 my @cols = BSE::TB::Image->columns;
ca9aa2bf 2833 shift @cols;
f40af7e2 2834 my $imageobj = BSE::TB::Images->add(@image{@cols});
a0a8147b 2835
bf87e97c 2836 my $storage = $opts{storage};
e63c3728 2837 defined $storage or $storage = 'local';
bf87e97c 2838 my $image_manager = $self->_image_manager($cfg);
e63c3728
TC
2839 local $SIG{__DIE__};
2840 eval {
2841 my $src;
2842 $storage = $image_manager->select_store($filename, $storage, $imageobj);
2843 $src = $image_manager->store($filename, $storage, $imageobj);
2844
2845 if ($src) {
2846 $imageobj->{src} = $src;
2847 $imageobj->{storage} = $storage;
2848 $imageobj->save;
2849 }
2850 };
2851 if ($@) {
bf87e97c 2852 $errors->{flash} = $@;
e63c3728
TC
2853 }
2854
bf87e97c
TC
2855 return $imageobj;
2856}
2857
2858sub add_image {
2859 my ($self, $req, $article, $articles) = @_;
2860
aa6896b6
TC
2861 $req->check_csrf("admin_add_image")
2862 or return $self->csrf_error($req, $article, "admin_add_image", "Add Image");
bf87e97c
TC
2863 $req->user_can(edit_images_add => $article)
2864 or return $self->_service_error($req, $article, $articles,
2865 "You don't have access to add new images to this article");
2866
2867 my $cgi = $req->cgi;
2868 my %errors;
2869 my $imageobj =
2870 $self->do_add_image
2871 (
2872 $req->cfg,
2873 $article,
2874 scalar($cgi->param('image')),
2875 name => scalar($cgi->param('name')),
2876 alt => scalar($cgi->param('altIn')),
2877 url => scalar($cgi->param('url')),
2878 storage => scalar($cgi->param('storage')),
2879 errors => \%errors,
2880 );
2881
2882 $imageobj
2883 or return $self->_service_error($req, $article, $articles, undef, \%errors);
2884
2885 # typically a soft failure from the storage
2886 $errors{flash}
2887 and $req->flash($errors{flash});
2888
a0a8147b
TC
2889 use Util 'generate_article';
2890 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2891
dbcd12e5
TC
2892 if ($cgi->param('_service')) {
2893 return $self->_service_success
2894 (
2895 {
2896 image => $imageobj->{id},
2897 },
2898 );
2899 }
2900 else {
2901 return $self->refresh($article, $cgi, undef, 'New image added');
2902 }
ca9aa2bf
TC
2903}
2904
e63c3728
TC
2905sub _image_manager {
2906 my ($self) = @_;
2907
2908 require BSE::StorageMgr::Images;
2909
2910 return BSE::StorageMgr::Images->new(cfg => $self->cfg);
2911}
2912
ca9aa2bf
TC
2913# remove an image
2914sub remove_img {
2915 my ($self, $req, $article, $articles, $imageid) = @_;
2916
aa6896b6
TC
2917 $req->check_csrf("admin_remove_image")
2918 or return $self->csrf_error($req, $article, "admin_remove_image", "Remove Image");
2919
abf5bbc6 2920 $req->user_can(edit_images_delete => $article)
cc9019d1 2921 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2922 "You don't have access to delete images from this article");
2923
ca9aa2bf
TC
2924 $imageid or die;
2925
daee3409 2926 my @images = $self->get_images($article);
ca9aa2bf
TC
2927 my ($image) = grep $_->{id} == $imageid, @images
2928 or return $self->show_images($req, $article, $articles, "No such image");
e63c3728
TC
2929
2930 if ($image->{storage} ne 'local') {
2931 my $mgr = $self->_image_manager($req->cfg);
2932 $mgr->unstore($image->{image}, $image->{storage});
2933 }
2934
ab2cd916 2935 my $imagedir = cfg_image_dir($req->cfg);
6473c56f 2936 unlink "$imagedir$image->{image}";
ca9aa2bf
TC
2937 $image->remove;
2938
a0a8147b
TC
2939 use Util 'generate_article';
2940 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2941
cc9019d1 2942 return $self->refresh($article, $req->cgi, undef, 'Image removed');
ca9aa2bf
TC
2943}
2944
2945sub move_img_up {
2946 my ($self, $req, $article, $articles) = @_;
2947
aa6896b6
TC
2948 $req->check_csrf("admin_move_image")
2949 or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
abf5bbc6 2950 $req->user_can(edit_images_reorder => $article)
cc9019d1 2951 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2952 "You don't have access to reorder images in this article");
2953
ca9aa2bf 2954 my $imageid = $req->cgi->param('imageid');
daee3409 2955 my @images = $self->get_images($article);
ca9aa2bf 2956 my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
cc9019d1 2957 or return $self->edit_form($req, $article, $articles, "No such image");
ca9aa2bf 2958 $imgindex > 0
cc9019d1 2959 or return $self->edit_form($req, $article, $articles, "Image is already at the top");
ca9aa2bf
TC
2960 my ($to, $from) = @images[$imgindex-1, $imgindex];
2961 ($to->{displayOrder}, $from->{displayOrder}) =
2962 ($from->{displayOrder}, $to->{displayOrder});
2963 $to->save;
2964 $from->save;
2965
a0a8147b
TC
2966 use Util 'generate_article';
2967 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2968
cc9019d1 2969 return $self->refresh($article, $req->cgi, undef, 'Image moved');
ca9aa2bf
TC
2970}
2971
2972sub move_img_down {
2973 my ($self, $req, $article, $articles) = @_;
2974
aa6896b6
TC
2975 $req->check_csrf("admin_move_image")
2976 or return $self->csrf_error($req, $article, "admin_move_image", "Move Image");
abf5bbc6 2977 $req->user_can(edit_images_reorder => $article)
cc9019d1 2978 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
2979 "You don't have access to reorder images in this article");
2980
ca9aa2bf 2981 my $imageid = $req->cgi->param('imageid');
daee3409 2982 my @images = $self->get_images($article);
ca9aa2bf 2983 my ($imgindex) = grep $images[$_]{id} == $imageid, 0..$#images
cc9019d1 2984 or return $self->edit_form($req, $article, $articles, "No such image");
ca9aa2bf 2985 $imgindex < $#images
cc9019d1 2986 or return $self->edit_form($req, $article, $articles, "Image is already at the end");
ca9aa2bf
TC
2987 my ($to, $from) = @images[$imgindex+1, $imgindex];
2988 ($to->{displayOrder}, $from->{displayOrder}) =
2989 ($from->{displayOrder}, $to->{displayOrder});
2990 $to->save;
2991 $from->save;
2992
a0a8147b
TC
2993 use Util 'generate_article';
2994 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2995
cc9019d1 2996 return $self->refresh($article, $req->cgi, undef, 'Image moved');
ca9aa2bf
TC
2997}
2998
ab2cd916
TC
2999sub req_thumb {
3000 my ($self, $req, $article) = @_;
3001
3002 my $cgi = $req->cgi;
3003 my $cfg = $req->cfg;
3004 my $im_id = $cgi->param('im');
3005 my $image;
3006 if (defined $im_id && $im_id =~ /^\d+$/) {
6a8a6ac5 3007 ($image) = grep $_->{id} == $im_id, $self->get_images($article);
ab2cd916
TC
3008 }
3009 my $thumb_obj = $self->_get_thumbs_class();
3010 my ($data, $type);
3011 if ($image && $thumb_obj) {
195977cd
TC
3012 my $geometry_id = $cgi->param('g');
3013 defined $geometry_id or $geometry_id = 'editor';
dbcd12e5 3014 my $geometry = $cfg->entry('thumb geometries', $geometry_id, 'scale(200x200)');
ab2cd916
TC
3015 my $imagedir = $cfg->entry('paths', 'images', $Constants::IMAGEDIR);
3016
195977cd 3017 my $error;
6430ee52
TC
3018 ($data, $type) = $thumb_obj->thumb_data
3019 (
3020 filename => "$imagedir/$image->{image}",
3021 geometry => $geometry,
3022 error => \$error
3023 )
d9f8d6b9
TC
3024 or return
3025 {
3026 type => 'text/plain',
3027 content => 'Error: '.$error
3028 };
ab2cd916
TC
3029 }
3030
3031 if ($type && $data) {
3032
3033 return
3034 {
3035 type => $type,
3036 content => $data,
3037 headers => [
3038 "Content-Length: ".length($data),
3039 "Cache-Control: max-age=3600",
3040 ],
3041 };
3042 }
3043 else {
3044 # grab the nothumb image
3045 my $uri = $cfg->entry('editor', 'default_thumbnail', '/images/admin/nothumb.png');
3046 my $filebase = $Constants::CONTENTBASE;
3047 if (open IMG, "<$filebase/$uri") {
3048 binmode IMG;
3049 my $data = do { local $/; <IMG> };
3050 close IMG;
3051 my $type = $uri =~ /\.(\w+)$/ ? $1 : 'png';
3052 return
3053 {
3054 type => "image/$type",
3055 content => $data,
3056 headers => [ "Content-Length: ".length($data) ],
3057 };
3058 }
3059 else {
3060 return
3061 {
3062 type=>"text/html",
3063 content => "<html><body>Cannot make thumb or default image</body></html>",
3064 };
3065 }
3066 }
3067}
3068
b95fc3a0
TC
3069sub req_edit_image {
3070 my ($self, $req, $article, $articles, $errors) = @_;
3071
3072 my $cgi = $req->cgi;
3073
3074 my $id = $cgi->param('image_id');
3075
7303cf10 3076 my ($image) = grep $_->{id} == $id, $self->get_images($article)
b95fc3a0
TC
3077 or return $self->edit_form($req, $article, $articles,
3078 "No such image");
3079 $req->user_can(edit_images_save => $article)
3080 or return $self->edit_form($req, $article, $articles,
3081 "You don't have access to save image information for this article");
3082
3083 my %acts;
3084 %acts =
3085 (
3086 $self->low_edit_tags(\%acts, $req, $article, $articles, undef,
3087 $errors),
3088 eimage => [ \&tag_hash, $image ],
7303cf10 3089 error_img => [ \&tag_error_img, $req->cfg, $errors ],
b95fc3a0
TC
3090 );
3091
3092 return $req->response('admin/image_edit', \%acts);
3093}
3094
3095sub req_save_image {
3096 my ($self, $req, $article, $articles) = @_;
3097
aa6896b6
TC
3098 $req->check_csrf("admin_save_image")
3099 or return $self->csrf_error($req, $article, "admin_save_image", "Save Image");
b95fc3a0
TC
3100 my $cgi = $req->cgi;
3101
3102 my $id = $cgi->param('image_id');
3103
7303cf10 3104 my @images = $self->get_images($article);
b95fc3a0
TC
3105 my ($image) = grep $_->{id} == $id, @images
3106 or return $self->edit_form($req, $article, $articles,
3107 "No such image");
3108 $req->user_can(edit_images_save => $article)
3109 or return $self->edit_form($req, $article, $articles,
3110 "You don't have access to save image information for this article");
3111
3112 my $image_dir = cfg_image_dir($req->cfg);
3113
e63c3728
TC
3114 my $old_storage = $image->{storage};
3115
b95fc3a0
TC
3116 my %errors;
3117 my $delete_file;
3118 my $alt = $cgi->param('alt');
3119 defined $alt and $image->{alt} = $alt;
3120 my $url = $cgi->param('url');
3121 defined $url and $image->{url} = $url;
3122 my @other_images = grep $_->{id} != $id, @images;
3123 my $name = $cgi->param('name');
3124 if (defined $name) {
3125 if (length $name) {
3126 if ($name !~ /^[a-z_]\w*$/i) {
3127 $errors{name} = 'Image name must be empty or alphanumeric and unique to the article';
3128 }
3129 elsif (grep $name eq $_->{name}, @other_images) {
3130 $errors{name} = 'Image name must be unique to the article';
3131 }
3132 else {
3133 $image->{name} = $name;
3134 }
3135 }
2d83755d 3136 else {
547a26ad
TC
3137 if ($article->{id} == -1) {
3138 $errors{name} = "Identifiers are required for global images";
3139 }
3140 else {
3141 $image->{name} = '';
3142 }
2d83755d 3143 }
b95fc3a0
TC
3144 }
3145 my $filename = $cgi->param('image');
3146 if (defined $filename && length $filename) {
3147 my $in_fh = $cgi->upload('image');
3148 if ($in_fh) {
3149 require DevHelp::FileUpload;
3150 my $msg;
3151 my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3152 ($image_dir, $filename . '', \$msg);
3153 if ($image_name) {
3154 {
3155 local $/ = \8192;
3156 my $data;
3157 while ($data = <$in_fh>) {
3158 print $out_fh $data;
3159 }
3160 close $out_fh;
3161 }
3162
3163 my $full_filename = "$image_dir/$image_name";
3164 require Image::Size;
3165 my ($width, $height, $type) = Image::Size::imgsize($full_filename);
3166 if ($width) {
3167 $delete_file = $image->{image};
3168 $image->{image} = $image_name;
3169 $image->{width} = $width;
3170 $image->{height} = $height;
e63c3728
TC
3171 $image->{storage} = 'local'; # not on the remote store yet
3172 $image->{src} = '/images/' . $image_name;
5d1b1cbb 3173 $image->{ftype} = $self->_image_ftype($type);
b95fc3a0
TC
3174 }
3175 else {
3176 $errors{image} = $type;
3177 }
3178 }
3179 else {
3180 $errors{image} = $msg;
3181 }
3182 }
3183 else {
3184 $errors{image} = "No image file received";
3185 }
3186 }
3187 keys %errors
3188 and return $self->req_edit_image($req, $article, $articles, \%errors);
3189
e63c3728
TC
3190 my $new_storage = $cgi->param('storage');
3191 defined $new_storage or $new_storage = $image->{storage};
b95fc3a0 3192 $image->save;
e63c3728
TC
3193 my $mgr = $self->_image_manager($req->cfg);
3194 if ($delete_file) {
3195 if ($old_storage ne 'local') {
3196 $mgr->unstore($delete_file, $old_storage);
3197 }
3198 unlink "$image_dir/$delete_file";
3199 }
3200 $req->flash("Image saved");
3201 eval {
3202 $new_storage =
3203 $mgr->select_store($image->{image}, $new_storage);
3204 if ($image->{storage} ne $new_storage) {
3205 # handles both new images (which sets storage to local) and changing
3206 # the storage for old images
3207 my $old_storage = $image->{storage};
3208 my $src = $mgr->store($image->{image}, $new_storage, $image);
3209 $image->{src} = $src;
3210 $image->{storage} = $new_storage;
3211 $image->save;
3212 }
3213 };
3214 $@ and $req->flash("There was a problem adding it to the new storage: $@");
3215 if ($image->{storage} ne $old_storage && $old_storage ne 'local') {
3216 eval {
3217 $mgr->unstore($image->{image}, $old_storage);
3218 };
3219 $@ and $req->flash("There was a problem removing if from the old storage: $@");
3220 }
b95fc3a0 3221
e63c3728 3222 return $self->refresh($article, $cgi);
b95fc3a0
TC
3223}
3224
ca9aa2bf
TC
3225sub get_article {
3226 my ($self, $articles, $article) = @_;
3227
3228 return $article;
3229}
3230
3231sub table_object {
3232 my ($self, $articles) = @_;
3233
3234 $articles;
3235}
3236
ca9aa2bf 3237sub _refresh_filelist {
8b0b2f34 3238 my ($self, $req, $article, $msg) = @_;
ca9aa2bf 3239
cc9019d1 3240 return $self->refresh($article, $req->cgi, undef, $msg);
ca9aa2bf
TC
3241}
3242
3243sub filelist {
918735d1 3244 my ($self, $req, $article, $articles, $msg, $errors) = @_;
ca9aa2bf
TC
3245
3246 my %acts;
918735d1 3247 %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
3248 my $template = 'admin/filelist';
3249
3250 return BSE::Template->get_response($template, $req->cfg, \%acts);
3251}
3252
4b69925d
TC
3253my %file_fields =
3254 (
3255 file =>
3256 {
3257 maxlength => MAX_FILE_DISPLAYNAME_LENGTH,
3258 description => 'Filename'
3259 },
3260 description =>
3261 {
3262 rules => 'dh_one_line',
3263 maxlength => 255,
3264 description => 'Description',
3265 },
3266 name =>
3267 {
3268 description => 'Identifier',
3269 maxlength => 80,
3270 },
6430ee52
TC
3271 category =>
3272 {
3273 description => "Category",
3274 maxlength => 20,
3275 },
4b69925d
TC
3276 );
3277
ca9aa2bf
TC
3278sub fileadd {
3279 my ($self, $req, $article, $articles) = @_;
3280
aa6896b6
TC
3281 $req->check_csrf("admin_add_file")
3282 or return $self->csrf_error($req, $article, "admin_add_file", "Add File");
abf5bbc6 3283 $req->user_can(edit_files_add => $article)
cc9019d1 3284 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
3285 "You don't have access to add files to this article");
3286
ca9aa2bf
TC
3287 my %file;
3288 my $cgi = $req->cgi;
6430ee52
TC
3289 require BSE::TB::ArticleFiles;
3290 my @cols = BSE::TB::ArticleFile->columns;
ca9aa2bf
TC
3291 shift @cols;
3292 for my $col (@cols) {
3293 if (defined $cgi->param($col)) {
3294 $file{$col} = $cgi->param($col);
3295 }
3296 }
c5286ebe
TC
3297
3298 my %errors;
ca9aa2bf 3299
4b69925d
TC
3300 $req->validate(errors => \%errors,
3301 fields => \%file_fields,
3302 section => $article->{id} == -1 ? 'Global File Validation' : 'Article File Validation');
7646d96e 3303
ca9aa2bf
TC
3304 # build a filename
3305 my $file = $cgi->param('file');
3306 unless ($file) {
c5286ebe 3307 $errors{file} = 'Please enter a filename';
ca9aa2bf 3308 }
c5286ebe
TC
3309 if ($file && -z $file) {
3310 $errors{file} = 'File is empty';
ca9aa2bf 3311 }
7646d96e
TC
3312
3313 $file{forSale} = 0 + exists $file{forSale};
3314 $file{articleId} = $article->{id};
3315 $file{download} = 0 + exists $file{download};
3316 $file{requireUser} = 0 + exists $file{requireUser};
3317 $file{hide_from_list} = 0 + exists $file{hide_from_list};
3318 $file{category} ||= '';
c5286ebe
TC
3319
3320 defined $file{name} or $file{name} = '';
9366cd70
TC
3321 if ($article->{id} == -1 && $file{name} eq '') {
3322 $errors{name} = 'Identifier is required for global files';
3323 }
3324 if (!$errors{name} && length $file{name} && $file{name} !~/^\w+$/) {
c5286ebe
TC
3325 $errors{name} = "Identifier must be a single word";
3326 }
3327 if (!$errors{name} && length $file{name}) {
9366cd70 3328 my @files = $self->get_files($article);
c5286ebe
TC
3329 if (grep lc $_->{name} eq lc $file{name}, @files) {
3330 $errors{name} = "Duplicate file identifier $file{name}";
3331 }
3332 }
3333
3334 keys %errors
3335 and return $self->edit_form($req, $article, $articles, undef, \%errors);
ca9aa2bf
TC
3336
3337 my $basename = '';
6a8a205a
TC
3338 my $workfile = $file;
3339 $workfile =~ s![^\w.:/\\-]+!_!g;
3340 $workfile =~ tr/_/_/s;
3341 $workfile =~ /([ \w.-]+)$/ and $basename = $1;
f0543260 3342 $basename =~ tr/ /_/;
7646d96e
TC
3343 $file{displayName} = $basename;
3344 $file{file} = $file;
ca9aa2bf 3345
7646d96e
TC
3346 local $SIG{__DIE__};
3347 my $fileobj =
3348 eval {
3349 $article->add_file($self->cfg, %file);
3350 };
4b69925d 3351
7646d96e
TC
3352 $fileobj
3353 or return $self->edit_form($req, $article, $articles, $@);
4b69925d 3354
7646d96e 3355 $req->flash("New file added");
ca9aa2bf 3356
cf34aa90 3357 my $storage = $cgi->param("storage") || "";
7646d96e
TC
3358 eval {
3359 my $msg;
ca9aa2bf 3360
7646d96e 3361 $article->apply_storage($self->cfg, $fileobj, $storage, \$msg);
ca9aa2bf 3362
7646d96e
TC
3363 $msg and $req->flash($msg);
3364 };
3365 $@
3366 and $req->flash($@);
ca9aa2bf 3367
7646d96e 3368# my $downloadPath = $self->{cfg}->entryVar('paths', 'downloads');
ca9aa2bf 3369
ca9aa2bf 3370
7646d96e
TC
3371# unless ($file{contentType}) {
3372# unless ($file =~ /\.([^.]+)$/) {
3373# $file{contentType} = "application/octet-stream";
3374# }
3375# unless ($file{contentType}) {
3376# $file{contentType} = content_type($self->cfg, $file);
3377# }
3378# }
ca9aa2bf 3379
ca9aa2bf 3380
7646d96e
TC
3381# # if the user supplies a really long filename, it can overflow the
3382# # filename field
ca9aa2bf 3383
7646d96e
TC
3384# my $work_filename = $basename;
3385# if (length $work_filename > 60) {
3386# $work_filename = substr($work_filename, -60);
3387# }
ca9aa2bf 3388
7646d96e 3389# my $filename = time. '_'. $work_filename;
ca9aa2bf 3390
7646d96e
TC
3391# # for the sysopen() constants
3392# use Fcntl;
e63c3728 3393
7646d96e
TC
3394# # loop until we have a unique filename
3395# my $counter="";
3396# $filename = time. '_' . $counter . '_' . $work_filename
3397# until sysopen( OUTPUT, "$downloadPath/$filename",
3398# O_WRONLY| O_CREAT| O_EXCL)
3399# || ++$counter > 100;
e63c3728 3400
7646d96e 3401# fileno(OUTPUT) or die "Could not open file: $!";
6430ee52 3402
7646d96e
TC
3403# # for OSs with special text line endings
3404# binmode OUTPUT;
e63c3728 3405
7646d96e
TC
3406# my $buffer;
3407
3408# no strict 'refs';
3409
3410# # read the image in from the browser and output it to our output filehandle
3411# print OUTPUT $buffer while read $file, $buffer, 8192;
3412
3413# # close and flush
3414# close OUTPUT
3415#