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