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