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