allow more than a trailing alphanumeric part of an image filename to live
[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
43c194df 19our $VERSION = "1.055";
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 ||
46541e94 252 $parent->{generator} eq 'BSE::Generate::Catalog');
ca9aa2bf
TC
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 262 my @parents = $articles->getBy('level', $article->{level}-1);
39e87dbd 263 @parents = grep { $_->{generator} eq 'BSE::Generate::Article'
ca9aa2bf 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 368 $article->{id} or return;
e0ed81d7 369 if (UNIVERSAL::isa($article, 'BSE::TB::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
0c2d3f00
AO
569 require BSE::TB::OtherParents;
570 my @stepkids = BSE::TB::OtherParents->getBy(parentId=>$article->{id}) if $article->{id};
ca9aa2bf 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
0c2d3f00
AO
676 require BSE::TB::OtherParents;
677 BSE::TB::OtherParents->getBy(childId=>$article->{id});
ca9aa2bf
TC
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 => "",
ea9b63f1 1167 type => "date",
59fca225
TC
1168 },
1169 customDate2 =>
1170 {
1171 rules => "date",
1172 htmltype => "text",
1173 width => 10,
1174 default => "",
ea9b63f1 1175 type => "date",
59fca225
TC
1176 },
1177 customStr1 =>
1178 {
1179 htmltype => "text",
1180 default => "",
1181 },
1182 customStr2 =>
1183 {
1184 htmltype => "text",
1185 default => "",
1186 },
1187 customInt1 =>
1188 {
1189 rules => "integer",
1190 htmltype => "text",
1191 width => 10,
1192 default => "",
1193 },
1194 customInt2 =>
1195 {
1196 rules => "integer",
1197 htmltype => "text",
1198 width => 10,
1199 default => "",
1200 },
1201 customInt3 =>
1202 {
1203 rules => "integer",
1204 htmltype => "text",
1205 width => 10,
1206 default => "",
1207 },
1208 customInt4 =>
1209 {
1210 rules => "integer",
1211 htmltype => "text",
1212 width => 10,
1213 default => "",
1214 },
1215 );
1216
1217sub custom_fields {
1218 my $self = shift;
1219
1220 require DevHelp::Validate;
1221 DevHelp::Validate->import;
d118f17b 1222 return DevHelp::Validate::dh_configure_fields
59fca225
TC
1223 (
1224 \%base_custom_validation,
1225 $self->cfg,
1226 ARTICLE_CUSTOM_FIELDS_CFG,
1227 BSE::DB->single->dbh,
1228 );
d118f17b
TC
1229}
1230
1231sub _custom_fields {
1232 my $self = shift;
1233
1234 my $fields = $self->custom_fields;
ea9b63f1
TC
1235 my %active;
1236 for my $key (keys %$fields) {
1237 $fields->{$key}{description}
1238 and $active{$key} = $fields->{$key};
1239 }
1240
1241 return \%active;
59fca225
TC
1242}
1243
ca9aa2bf
TC
1244sub low_edit_tags {
1245 my ($self, $acts, $request, $article, $articles, $msg, $errors) = @_;
1246
1247 my $cgi = $request->cgi;
ab2cd916 1248 my $show_full = $cgi->param('f_showfull');
6a5227d4 1249 my $if_error = $msg || ($errors && keys %$errors) || $request->cgi->param("_e");
c0bf9781
TC
1250 #$msg ||= join "\n", map escape_html($_), $cgi->param('message'), $cgi->param('m');
1251 $msg .= $request->message($errors);
abf5bbc6
TC
1252 my $parent;
1253 if ($article->{id}) {
1254 if ($article->{parentid} > 0) {
1255 $parent = $article->parent;
1256 }
1257 else {
1258 $parent = { title=>"No parent - this is a section", id=>-1 };
1259 }
1260 }
1261 else {
1262 $parent = { title=>"How did we get here?", id=>0 };
1263 }
0580ff34
TC
1264 $request->set_article(article => $article);
1265 $request->set_variable(ifnew => !$article->{id});
62533efa
TC
1266 my $cfg = $self->{cfg};
1267 my $mbcs = $cfg->entry('html', 'mbcs', 0);
1268 my $tag_hash = $mbcs ? \&tag_hash_mbcs : \&tag_hash;
ab2cd916
TC
1269 my $thumbs_obj_real = $self->_get_thumbs_class();
1270 my $thumbs_obj = $show_full ? undef : $thumbs_obj_real;
ca9aa2bf
TC
1271 my @images;
1272 my $image_index;
ab2cd916 1273 my $current_image;
ca9aa2bf
TC
1274 my @children;
1275 my $child_index;
1276 my %stepkids;
ca9aa2bf
TC
1277 my @allkids;
1278 my $allkid_index;
1279 my @possstepkids;
1280 my @stepparents;
1281 my $stepparent_index;
1282 my @stepparent_targs;
1283 my @stepparentpossibles;
1284 my @files;
1285 my $file_index;
c2096d67
TC
1286 my @groups;
1287 my $current_group;
ab2cd916 1288 my $it = BSE::Util::Iterate->new;
76c6b28e 1289 my $ito = BSE::Util::Iterate::Objects->new;
ea71fc0d 1290 my $ita = BSE::Util::Iterate::Article->new(req => $request);
59fca225 1291
d118f17b 1292 my $custom = $self->_custom_fields;
3c8f6fb2 1293 # only return the fields that are defined
ea9b63f1 1294 $request->set_variable(custom => $custom);
c0c1747b 1295 $request->set_variable(errors => $errors || {});
0bdcab3b
TC
1296 my $article_type = $cfg->entry('level names', $article->{level}, 'Article');
1297 $request->set_variable(article_type => $article_type);
59fca225 1298
ca9aa2bf
TC
1299 return
1300 (
58baa27b 1301 $request->admin_tags,
86dc77f9 1302 article => sub { tag_article($article, $cfg, $_[0]) },
ca9aa2bf 1303 old => [ \&tag_old, $article, $cgi ],
9168c88c 1304 default => [ \&tag_default, $self, $request, $article ],
0bdcab3b 1305 articleType => escape_html($article_type),
ca9aa2bf 1306 parentType => [ \&tag_art_type, $article->{level}-1, $cfg ],
918735d1 1307 ifNew => [ \&tag_if_new, $article ],
9168c88c 1308 list => [ \&tag_list, $self, $article, $articles, $cgi, $request ],
ca9aa2bf
TC
1309 script => $ENV{SCRIPT_NAME},
1310 level => $article->{level},
1311 checked => \&tag_checked,
ab2cd916 1312 $it->make_iterator
daee3409 1313 ([ \&iter_get_images, $self, $article ], 'image', 'images', \@images,
ab2cd916 1314 \$image_index, undef, \$current_image),
f40af7e2 1315 image => [ tag_image => $self, $cfg, \$current_image ],
ab2cd916
TC
1316 thumbimage => [ \&tag_thumbimage, $cfg, $thumbs_obj, \$current_image ],
1317 ifThumbs => defined($thumbs_obj),
1318 ifCanThumbs => defined($thumbs_obj_real),
abf5bbc6 1319 imgmove => [ \&tag_imgmove, $request, $article, \$image_index, \@images ],
ca9aa2bf 1320 message => $msg,
6a5227d4 1321 ifError => $if_error,
ea71fc0d
TC
1322 $ita->make
1323 (
1324 code => [ \&iter_get_kids, $article, $articles ],
1325 single => 'child',
1326 plural => 'children',
1327 data => \@children,
1328 index => \$child_index,
1329 ),
ca9aa2bf
TC
1330 ifchildren => \&tag_if_children,
1331 childtype => [ \&tag_art_type, $article->{level}+1, $cfg ],
1332 ifHaveChildType => [ \&tag_if_have_child_type, $article->{level}, $cfg ],
abf5bbc6
TC
1333 movechild => [ \&tag_movechild, $self, $request, $article, \@children,
1334 \$child_index],
ca9aa2bf
TC
1335 is => \&tag_is,
1336 templates => [ \&tag_templates, $self, $article, $cfg, $cgi ],
1337 titleImages => [ \&tag_title_images, $self, $article, $cfg, $cgi ],
1338 editParent => [ \&tag_edit_parent, $article ],
ea71fc0d
TC
1339 $ita->make
1340 (
1341 code => [ \&iter_allkids, $article ],
1342 single => 'kid',
1343 plural => 'kids',
1344 data => \@allkids,
1345 index => \$allkid_index,
1346 ),
ca9aa2bf
TC
1347 ifStepKid =>
1348 [ \&tag_if_step_kid, $article, \@allkids, \$allkid_index, \%stepkids ],
1349 stepkid => [ \&tag_step_kid, $article, \@allkids, \$allkid_index,
1350 \%stepkids ],
1351 movestepkid =>
31a26b52
TC
1352 [ \&tag_move_stepkid, $self, $cgi, $request, $article, \@allkids,
1353 \$allkid_index ],
ca9aa2bf 1354 possible_stepkids =>
31a26b52
TC
1355 [ \&tag_possible_stepkids, \%stepkids, $request, $article,
1356 \@possstepkids, $articles, $cgi ],
ca9aa2bf 1357 ifPossibles =>
31a26b52
TC
1358 [ \&tag_if_possible_stepkids, \%stepkids, $request, $article,
1359 \@possstepkids, $articles, $cgi ],
ea71fc0d
TC
1360 $ita->make
1361 (
1362 code => [ \&iter_get_stepparents, $article ],
1363 single => 'stepparent',
1364 plural => 'stepparents',
1365 data => \@stepparents,
1366 index => \$stepparent_index,
1367 ),
ca9aa2bf
TC
1368 ifStepParents => \&tag_ifStepParents,
1369 stepparent_targ =>
1370 [ \&tag_stepparent_targ, $article, \@stepparent_targs,
1371 \$stepparent_index ],
1372 movestepparent =>
31a26b52 1373 [ \&tag_move_stepparent, $self, $cgi, $request, $article, \@stepparents,
ca9aa2bf
TC
1374 \$stepparent_index ],
1375 ifStepparentPossibles =>
31a26b52
TC
1376 [ \&tag_if_stepparent_possibles, $request, $article, $articles,
1377 \@stepparent_targs, \@stepparentpossibles, ],
ca9aa2bf 1378 stepparent_possibles =>
31a26b52 1379 [ \&tag_stepparent_possibles, $cgi, $request, $article, $articles,
ca9aa2bf 1380 \@stepparent_targs, \@stepparentpossibles, ],
f738f7b4
TC
1381 $ito->make
1382 (
1383 code => [ iter_files => $self, $article ],
1384 single => 'file',
1385 plural => 'files',
1386 data => \@files,
1387 index => \$file_index,
1388 ),
abf5bbc6
TC
1389 movefiles =>
1390 [ \&tag_movefiles, $self, $request, $article, \@files, \$file_index ],
d745f64f
TC
1391 $it->make
1392 (
1393 code => [ iter_file_metas => $self, \@files, \$file_index ],
1394 plural => "file_metas",
1395 single => "file_meta",
1396 nocache => 1,
1397 ),
e05b1657
TC
1398 ifFileExists => sub {
1399 @files && $file_index >= 0 && $file_index < @files
1400 or return 0;
1401
1402 return -f ($files[$file_index]->full_filename($cfg));
1403 },
8aa7eb30 1404 file_display => [ tag_file_display => $self, \@files, \$file_index ],
08123550
TC
1405 DevHelp::Tags->make_iterator2
1406 (\&iter_admin_users, 'iadminuser', 'adminusers'),
1407 DevHelp::Tags->make_iterator2
1408 (\&iter_admin_groups, 'iadmingroup', 'admingroups'),
f2bf0d11 1409 edit => [ \&tag_edit_link, $cfg, $article ],
62533efa 1410 error => [ $tag_hash, $errors ],
b553afa2 1411 error_img => [ \&tag_error_img, $cfg, $errors ],
9168c88c 1412 ifFieldPerm => [ \&tag_if_field_perm, $request, $article ],
ea71fc0d 1413 parent => [ \&tag_article, $parent, $cfg ],
918735d1
TC
1414 DevHelp::Tags->make_iterator2
1415 ([ \&iter_flags, $self ], 'flag', 'flags' ),
1416 ifFlagSet => [ \&tag_if_flag_set, $article ],
8b0b2f34
TC
1417 DevHelp::Tags->make_iterator2
1418 ([ \&iter_crumbs, $article, $articles ], 'crumb', 'crumbs' ),
1419 typename => \&tag_typename,
c2096d67
TC
1420 $it->make_iterator([ \&iter_groups, $request ],
1421 'group', 'groups', \@groups, undef, undef,
1422 \$current_group),
e63c3728
TC
1423 $it->make_iterator([ iter_image_stores => $self],
1424 'image_store', 'image_stores'),
1425 $it->make_iterator([ iter_file_stores => $self],
1426 'file_store', 'file_stores'),
c2096d67 1427 ifGroupRequired => [ \&tag_ifGroupRequired, $article, \$current_group ],
dbfbfb12 1428 category => [ tag_category => $self, $articles, $article ],
76c6b28e
TC
1429 $ito->make
1430 (
1431 single => "tag",
1432 plural => "tags",
1433 code => [ iter_tags => $self, $article ],
1434 ),
ca9aa2bf
TC
1435 );
1436}
1437
e63c3728
TC
1438sub iter_image_stores {
1439 my ($self) = @_;
1440
1441 my $mgr = $self->_image_manager;
1442
1443 return map +{ name => $_->name, description => $_->description },
1444 $mgr->all_stores;
1445}
1446
1447sub _file_manager {
1448 my ($self) = @_;
1449
7646d96e 1450 require BSE::TB::ArticleFiles;
e63c3728 1451
7646d96e 1452 return BSE::TB::ArticleFiles->file_manager($self->cfg);
e63c3728
TC
1453}
1454
1455sub iter_file_stores {
1456 my ($self) = @_;
1457
7646d96e
TC
1458 require BSE::TB::ArticleFiles;
1459 my $mgr = $self->_file_manager($self->cfg);
e63c3728
TC
1460
1461 return map +{ name => $_->name, description => $_->description },
1462 $mgr->all_stores;
1463}
1464
c2096d67
TC
1465sub iter_groups {
1466 my ($req) = @_;
1467
1468 require BSE::TB::SiteUserGroups;
1469 BSE::TB::SiteUserGroups->admin_and_query_groups($req->cfg);
1470}
1471
1472sub tag_ifGroupRequired {
1473 my ($article, $rgroup) = @_;
1474
b876ce1c
TC
1475 $article->{id}
1476 or return 0;
1477
c2096d67
TC
1478 $$rgroup or return 0;
1479
1480 $article->is_accessible_to($$rgroup);
1481}
1482
ca9aa2bf
TC
1483sub edit_template {
1484 my ($self, $article, $cgi) = @_;
1485
1486 my $base = $article->{level};
1487 my $t = $cgi->param('_t');
1488 if ($t && $t =~ /^\w+$/) {
1489 $base = $t;
1490 }
1491 return $self->{cfg}->entry('admin templates', $base,
1492 "admin/edit_$base");
1493}
1494
1495sub add_template {
1496 my ($self, $article, $cgi) = @_;
1497
1498 $self->edit_template($article, $cgi);
1499}
1500
1501sub low_edit_form {
1502 my ($self, $request, $article, $articles, $msg, $errors) = @_;
1503
1504 my $cgi = $request->cgi;
1505 my %acts;
1506 %acts = $self->low_edit_tags(\%acts, $request, $article, $articles, $msg,
1507 $errors);
1508 my $template = $article->{id} ?
1509 $self->edit_template($article, $cgi) : $self->add_template($article, $cgi);
1510
f2bf0d11 1511 return $request->response($template, \%acts);
ca9aa2bf
TC
1512}
1513
1514sub edit_form {
1515 my ($self, $request, $article, $articles, $msg, $errors) = @_;
1516
1517 return $self->low_edit_form($request, $article, $articles, $msg, $errors);
1518}
1519
aa6896b6
TC
1520sub _dummy_article {
1521 my ($self, $req, $articles, $rmsg) = @_;
ca9aa2bf
TC
1522
1523 my $level;
9168c88c 1524 my $cgi = $req->cgi;
ca9aa2bf
TC
1525 my $parentid = $cgi->param('parentid');
1526 if ($parentid) {
1527 if ($parentid =~ /^\d+$/) {
1528 if (my $parent = $self->get_parent($parentid, $articles)) {
1529 $level = $parent->{level}+1;
1530 }
1531 else {
1532 $parentid = undef;
1533 }
1534 }
1535 elsif ($parentid eq "-1") {
1536 $level = 1;
1537 }
1538 }
1539 unless (defined $level) {
1540 $level = $cgi->param('level');
1541 undef $level unless defined $level && $level =~ /^\d+$/
1542 && $level > 0 && $level < 100;
1543 defined $level or $level = 3;
1544 }
1545
1546 my %article;
e0ed81d7 1547 my @cols = BSE::TB::Article->columns;
ca9aa2bf
TC
1548 @article{@cols} = ('') x @cols;
1549 $article{id} = '';
1550 $article{parentid} = $parentid;
1551 $article{level} = $level;
1552 $article{body} = '<maximum of 64Kb>';
1553 $article{listed} = 1;
1554 $article{generator} = $self->generator;
1555
9168c88c 1556 my ($values, $labels) = $self->possible_parents(\%article, $articles, $req);
1b02d672 1557 unless (@$values) {
aa6896b6
TC
1558 $$rmsg = "You can't add children to any article at that level";
1559 return;
1560 }
1561
0bdcab3b
TC
1562 return $self->_make_dummy_article(\%article);
1563}
1564
1565sub _make_dummy_article {
1566 my ($self, $article) = @_;
1567
d5052b4d 1568 require BSE::DummyArticle;
0bdcab3b 1569 return bless $article, "BSE::DummyArticle";
aa6896b6
TC
1570}
1571
1572sub add_form {
d62f54f7 1573 my ($self, $req, $article, $articles, $msg, $errors) = @_;
9168c88c 1574
aa6896b6 1575 return $self->low_edit_form($req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
1576}
1577
39e87dbd 1578sub generator { 'BSE::Generate::Article' }
ca9aa2bf 1579
331fd099
TC
1580sub typename {
1581 my ($self) = @_;
1582
1583 my $gen = $self->generator;
1584
1585 ($gen =~ /(\w+)$/)[0] || 'Article';
1586}
1587
ca9aa2bf 1588sub _validate_common {
b553afa2 1589 my ($self, $data, $articles, $errors, $article) = @_;
ca9aa2bf 1590
918735d1
TC
1591# if (defined $data->{parentid} && $data->{parentid} =~ /^(?:-1|\d+)$/) {
1592# unless ($data->{parentid} == -1 or
1593# $articles->getByPkey($data->{parentid})) {
1594# $errors->{parentid} = "Selected parent article doesn't exist";
1595# }
1596# }
1597# else {
1598# $errors->{parentid} = "You need to select a valid parent";
1599# }
1600 if (exists $data->{title} && $data->{title} !~ /\S/) {
1601 $errors->{title} = "Please enter a title";
ca9aa2bf
TC
1602 }
1603
1604 if (exists $data->{template} && $data->{template} =~ /\.\./) {
1605 $errors->{template} = "Please only select templates from the list provided";
1606 }
c76e86ea
TC
1607 if (exists $data->{linkAlias}
1608 && length $data->{linkAlias}) {
90ee1626 1609 unless ($data->{linkAlias} =~ /\A[a-zA-Z0-9-_]+\z/
c76e86ea
TC
1610 && $data->{linkAlias} =~ /[A-Za-z]/) {
1611 $errors->{linkAlias} = "Link alias must contain only alphanumerics and contain at least one letter";
1612 }
1613 }
dbfbfb12
TC
1614
1615 if (defined $data->{category}) {
1616 unless (first { $_->{id} eq $data->{category} } $self->categories($articles)) {
1617 $errors->{category} = "msg:bse/admin/edit/category/unknown";
1618 }
1619 }
59fca225
TC
1620
1621 require DevHelp::Validate;
1622 DevHelp::Validate->import('dh_validate_hash');
1623 dh_validate_hash($data, $errors,
1624 {
d118f17b 1625 fields => $self->_custom_fields,
59fca225 1626 optional => 1,
b311d086 1627 dbh => BSE::DB->single->dbh,
59fca225
TC
1628 },
1629 $self->cfg, ARTICLE_CUSTOM_FIELDS_CFG);
ca9aa2bf
TC
1630}
1631
1632sub validate {
918735d1 1633 my ($self, $data, $articles, $errors) = @_;
ca9aa2bf
TC
1634
1635 $self->_validate_common($data, $articles, $errors);
c76e86ea
TC
1636 if (!$errors->{linkAlias} && defined $data->{linkAlias} && length $data->{linkAlias}) {
1637 my $other = $articles->getBy(linkAlias => $data->{linkAlias});
1638 $other
1639 and $errors->{linkAlias} =
1640 "Duplicate link alias - already used by article $other->{id}";
1641 }
331fd099
TC
1642 custom_class($self->{cfg})
1643 ->article_validate($data, undef, $self->typename, $errors);
ca9aa2bf
TC
1644
1645 return !keys %$errors;
1646}
1647
1648sub validate_old {
8f88bb20 1649 my ($self, $article, $data, $articles, $errors, $ajax) = @_;
ca9aa2bf 1650
b553afa2 1651 $self->_validate_common($data, $articles, $errors, $article);
331fd099
TC
1652 custom_class($self->{cfg})
1653 ->article_validate($data, $article, $self->typename, $errors);
ca9aa2bf 1654
8f88bb20
TC
1655 if (exists $data->{release}) {
1656 if ($ajax && !dh_parse_sql_date($data->{release})
1657 || !$ajax && !dh_parse_date($data->{release})) {
1658 $errors->{release} = "Invalid release date";
1659 }
b553afa2
TC
1660 }
1661
c76e86ea
TC
1662 if (!$errors->{linkAlias}
1663 && defined $data->{linkAlias}
1664 && length $data->{linkAlias}
1665 && $data->{linkAlias} ne $article->{linkAlias}) {
1666 my $other = $articles->getBy(linkAlias => $data->{linkAlias});
90ee1626 1667 $other && $other->{id} != $article->{id}
c76e86ea
TC
1668 and $errors->{linkAlias} = "Duplicate link alias - already used by article $other->{id}";
1669 }
1670
ca9aa2bf
TC
1671 return !keys %$errors;
1672}
1673
1674sub validate_parent {
1675 1;
1676}
1677
1678sub fill_new_data {
1679 my ($self, $req, $data, $articles) = @_;
1680
d118f17b 1681 my $custom = $self->_custom_fields;
59fca225
TC
1682 for my $key (keys %$custom) {
1683 my ($value) = $req->cgi->param($key);
ea9b63f1 1684 if (defined $value) {
59fca225 1685 if ($key =~ /^customDate/) {
ea9b63f1
TC
1686 require DevHelp::Date;
1687 my $msg;
1688 if (my ($year, $month, $day) =
1689 DevHelp::Date::dh_parse_date($value, \$msg)) {
1690 $data->{$key} = sprintf("%04d-%02d-%02d", $year, $month, $day);
59fca225
TC
1691 }
1692 else {
1693 $data->{$key} = undef;
1694 }
1695 }
1696 elsif ($key =~ /^customInt/) {
1697 if ($value =~ /\S/) {
1698 $data->{$key} = $value;
1699 }
1700 else {
1701 $data->{$key} = undef;
1702 }
1703 }
1704 else {
1705 $data->{$key} = $value;
1706 }
1707 }
1708 }
1709
331fd099
TC
1710 custom_class($self->{cfg})
1711 ->article_fill_new($data, $self->typename);
1712
ca9aa2bf
TC
1713 1;
1714}
1715
95989433
TC
1716sub link_path {
1717 my ($self, $article) = @_;
1718
1719 # check the config for the article and any of its ancestors
1720 my $work_article = $article;
1721 my $path = $self->{cfg}->entry('article uris', $work_article->{id});
1722 while (!$path) {
1723 last if $work_article->{parentid} == -1;
1724 $work_article = $work_article->parent;
1725 $path = $self->{cfg}->entry('article uris', $work_article->{id});
1726 }
1727 return $path if $path;
1728
1729 $self->default_link_path($article);
1730}
1731
1732sub default_link_path {
1733 my ($self, $article) = @_;
1734
1735 $self->{cfg}->entry('uri', 'articles', '/a');
1736}
1737
ca9aa2bf
TC
1738sub make_link {
1739 my ($self, $article) = @_;
1740
a739c25d
TC
1741 $article->is_linked
1742 or return "";
1743
3f9c8a96 1744 my $title = $article->title;
efcc5a30 1745 if ($article->is_dynamic) {
d4336bdc
TC
1746 (my $extra = $title) =~ tr/A-Za-z0-9/-/sc;
1747 return "/cgi-bin/page.pl?page=$article->{id}&title=".escape_uri($extra);
efcc5a30
TC
1748 }
1749
95989433 1750 my $article_uri = $self->link_path($article);
ca9aa2bf
TC
1751 my $link = "$article_uri/$article->{id}.html";
1752 my $link_titles = $self->{cfg}->entryBool('basic', 'link_titles', 0);
1753 if ($link_titles) {
d4336bdc 1754 (my $extra = $title) =~ tr/A-Za-z0-9/-/sc;
d7538448 1755 $link .= "/" . $extra . "_html";
ca9aa2bf
TC
1756 }
1757
1758 $link;
1759}
1760
dfd483db
TC
1761sub save_columns {
1762 my ($self, $table_object) = @_;
1763
0e4b5b38
TC
1764 my @columns = $table_object->rowClass->columns;
1765 shift @columns;
1766
1767 return @columns;
dfd483db
TC
1768}
1769
c46eae4a
TC
1770sub _validate_tags {
1771 my ($self, $tags, $errors) = @_;
1772
1773 my $fail = 0;
1774 my @errors;
1775 for my $tag (@$tags) {
1776 my $error;
1777 if ($tag =~ /\S/
1778 && !BSE::TB::Tags->valid_name($tag, \$error)) {
c941bc57 1779 push @errors, "msg:bse/admin/edit/tags/invalid/$error";
c46eae4a
TC
1780 $errors->{tags} = \@errors;
1781 ++$fail;
1782 }
1783 else {
1784 push @errors, undef;
1785 }
1786 }
1787
1788 return $fail;
1789}
1790
ca9aa2bf 1791sub save_new {
d62f54f7 1792 my ($self, $req, $article, $articles) = @_;
aa6896b6
TC
1793
1794 $req->check_csrf("admin_add_article")
1795 or return $self->csrf_error($req, undef, "admin_add_article", "Add Article");
ca9aa2bf
TC
1796
1797 my $cgi = $req->cgi;
1798 my %data;
1799 my $table_object = $self->table_object($articles);
dfd483db 1800 my @columns = $self->save_columns($table_object);
ca9aa2bf
TC
1801 $self->save_thumbnail($cgi, undef, \%data);
1802 for my $name (@columns) {
9168c88c
TC
1803 $data{$name} = $cgi->param($name)
1804 if defined $cgi->param($name);
ca9aa2bf 1805 }
918735d1 1806 $data{flags} = join '', sort $cgi->param('flags');
ca9aa2bf
TC
1807
1808 my $msg;
1809 my %errors;
718a070d
TC
1810 if (!defined $data{parentid} || $data{parentid} eq '') {
1811 $errors{parentid} = "Please select a parent";
1812 }
1813 elsif ($data{parentid} !~ /^(?:-1|\d+)$/) {
1814 $errors{parentid} = "Invalid parent selection (template bug)";
1815 }
39c06424 1816 $self->validate(\%data, $articles, \%errors);
76c6b28e
TC
1817
1818 my $save_tags = $cgi->param("_save_tags");
1819 my @tags;
1820 if ($save_tags) {
c46eae4a
TC
1821 @tags = $cgi->param("tags");
1822 $self->_validate_tags(\@tags, \%errors);
76c6b28e
TC
1823 }
1824
d5052b4d
TC
1825 my $meta;
1826 if ($cgi->param("_save_meta")) {
1827 require BSE::ArticleMetaMeta;
1828 $meta = BSE::ArticleMetaMeta->retrieve($req, $article, \%errors);
1829 }
1830
39c06424
TC
1831 if (keys %errors) {
1832 if ($req->is_ajax) {
1833 return $req->json_content
1834 (
1835 success => 0,
1836 errors => \%errors,
1837 error_code => "FIELD",
1838 message => $req->message(\%errors),
1839 );
1840 }
1841 else {
d62f54f7 1842 return $self->add_form($req, $article, $articles, $msg, \%errors);
39c06424
TC
1843 }
1844 }
ca9aa2bf
TC
1845
1846 my $parent;
39c06424
TC
1847 my $parent_msg;
1848 my $parent_code;
ca9aa2bf
TC
1849 if ($data{parentid} > 0) {
1850 $parent = $articles->getByPkey($data{parentid}) or die;
39c06424
TC
1851 if ($req->user_can('edit_add_child', $parent)) {
1852 for my $name (@columns) {
1853 if (exists $data{$name} &&
1854 !$req->user_can("edit_add_field_$name", $parent)) {
1855 delete $data{$name};
1856 }
9168c88c
TC
1857 }
1858 }
39c06424
TC
1859 else {
1860 $parent_msg = "You cannot add a child to that article";
1861 $parent_code = "ACCESS";
1862 }
ca9aa2bf 1863 }
9168c88c 1864 else {
39c06424
TC
1865 if ($req->user_can('edit_add_child')) {
1866 for my $name (@columns) {
1867 if (exists $data{$name} &&
1868 !$req->user_can("edit_add_field_$name")) {
1869 delete $data{$name};
1870 }
9168c88c
TC
1871 }
1872 }
39c06424
TC
1873 else {
1874 $parent_msg = "You cannot create a top-level article";
1875 $parent_code = "ACCESS";
1876 }
1877 }
1878 if (!$parent_msg) {
1879 $self->validate_parent(\%data, $articles, $parent, \$parent_msg)
1880 or $parent_code = "PARENT";
1881 }
1882 if ($parent_msg) {
1883 if ($req->is_ajax) {
1884 return $req->json_content
1885 (
1886 success => 0,
1887 message => $parent_msg,
1888 error_code => $parent_code,
1889 errors => {},
1890 );
1891 }
1892 else {
d62f54f7 1893 return $self->add_form($req, $article, $articles, $parent_msg);
39c06424 1894 }
9168c88c 1895 }
ca9aa2bf 1896
ca9aa2bf 1897 my $level = $parent ? $parent->{level}+1 : 1;
0ec4ac8a 1898 $data{level} = $level;
9168c88c 1899 $data{displayOrder} = time;
ca9aa2bf
TC
1900 $data{link} ||= '';
1901 $data{admin} ||= '';
ca9aa2bf 1902 $data{generator} = $self->generator;
41f10371 1903 $data{lastModified} = now_sqldatetime();
ca9aa2bf
TC
1904 $data{listed} = 1 unless defined $data{listed};
1905
9604a90c
TC
1906# Added by adrian
1907 $data{pageTitle} = '' unless defined $data{pageTitle};
1908 my $user = $req->getuser;
1909 $data{createdBy} = $user ? $user->{logon} : '';
1910 $data{lastModifiedBy} = $user ? $user->{logon} : '';
1911 $data{created} = now_sqldatetime();
12bcb7ac
TC
1912# end adrian
1913
efcc5a30
TC
1914 $data{force_dynamic} = 0;
1915 $data{cached_dynamic} = 0;
1916 $data{inherit_siteuser_rights} = 1;
9604a90c 1917
12bcb7ac
TC
1918# Added by adrian
1919 $data{metaDescription} = '' unless defined $data{metaDescription};
1920 $data{metaKeywords} = '' unless defined $data{metaKeywords};
1921# end adrian
1922
0ec4ac8a 1923 $self->fill_new_data($req, \%data, $articles);
dbfbfb12 1924 for my $col (qw(titleImage imagePos template keyword menu titleAlias linkAlias body author summary category)) {
0ec4ac8a
TC
1925 defined $data{$col}
1926 or $data{$col} = $self->default_value($req, \%data, $col);
1927 }
1928
c2096d67
TC
1929 for my $col (qw/force_dynamic inherit_siteuser_rights/) {
1930 if ($req->user_can("edit_add_field_$col", $parent)
1931 && $cgi->param("save_$col")) {
1932 $data{$col} = $cgi->param($col) ? 1 : 0;
1933 }
1934 else {
1935 $data{$col} = $self->default_value($req, \%data, $col);
1936 }
1937 }
1938
8f88bb20
TC
1939 unless ($req->is_ajax) {
1940 for my $col (qw(release expire)) {
1941 $data{$col} = sql_date($data{$col});
1942 }
718a070d
TC
1943 }
1944
0ec4ac8a 1945 # these columns are handled a little differently
d7538448 1946 for my $col (qw(release expire threshold summaryLength )) {
0ec4ac8a
TC
1947 $data{$col}
1948 or $data{$col} = $self->default_value($req, \%data, $col);
1949 }
1950
dfd483db
TC
1951 my @cols = $table_object->rowClass->columns;
1952 shift @cols;
0e4b5b38
TC
1953
1954 # fill out anything else from defaults
1955 for my $col (@columns) {
1956 exists $data{$col}
1957 or $data{$col} = $self->default_value($req, \%data, $col);
1958 }
1959
dfd483db
TC
1960 $article = $table_object->add(@data{@cols});
1961
1962 $self->save_new_more($req, $article, \%data);
ca9aa2bf
TC
1963
1964 # we now have an id - generate the links
1965
a319d280 1966 $article->update_dynamic($self->{cfg});
ca9aa2bf
TC
1967 my $cgi_uri = $self->{cfg}->entry('uri', 'cgi', '/cgi-bin');
1968 $article->setAdmin("$cgi_uri/admin/admin.pl?id=$article->{id}");
1969 $article->setLink($self->make_link($article));
1970 $article->save();
1971
78218ca8
TC
1972 my ($after_id) = $cgi->param("_after");
1973 if (defined $after_id) {
e0ed81d7 1974 BSE::TB::Articles->reorder_child($article->{parentid}, $article->{id}, $after_id);
78218ca8
TC
1975 # reload, the displayOrder probably changed
1976 $article = $articles->getByPkey($article->{id});
1977 }
1978
76c6b28e
TC
1979 if ($save_tags) {
1980 my $error;
c46eae4a 1981 $article->set_tags([ grep /\S/, @tags ], \$error);
76c6b28e
TC
1982 }
1983
d5052b4d
TC
1984 if ($meta) {
1985 BSE::ArticleMetaMeta->save($article, $meta);
1986 }
1987
caa7299c
TC
1988 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
1989
8f88bb20 1990 if ($req->is_ajax) {
8f88bb20
TC
1991 return $req->json_content
1992 (
1993 {
1994 success => 1,
1995 article => $self->_article_data($req, $article),
1996 },
1997 );
1998 }
1999
8b0b2f34
TC
2000 my $r = $cgi->param('r');
2001 if ($r) {
2002 $r .= ($r =~ /\?/) ? '&' : '?';
2003 $r .= "id=$article->{id}";
2004 }
2005 else {
41f10371 2006 $r = admin_base_url($req->cfg) . $article->{admin};
8b0b2f34
TC
2007 }
2008 return BSE::Template->get_refresh($r, $self->{cfg});
ca9aa2bf
TC
2009}
2010
2011sub fill_old_data {
0d5ccc7f 2012 my ($self, $req, $article, $data) = @_;
ca9aa2bf 2013
4010d92e
TC
2014 if (exists $data->{body}) {
2015 $data->{body} =~ s/\x0D\x0A/\n/g;
2016 $data->{body} =~ tr/\r/\n/;
2017 }
e0ed81d7 2018 for my $col (BSE::TB::Article->columns) {
331fd099 2019 next if $col =~ /^custom/;
ca9aa2bf
TC
2020 $article->{$col} = $data->{$col}
2021 if exists $data->{$col} && $col ne 'id' && $col ne 'parentid';
2022 }
d118f17b 2023 my $custom = $self->_custom_fields;
59fca225 2024 for my $key (keys %$custom) {
ea9b63f1 2025 if (exists $data->{$key}) {
59fca225 2026 if ($key =~ /^customDate/) {
ea9b63f1
TC
2027 require DevHelp::Date;
2028 my $msg;
2029 if (my ($year, $month, $day) =
2030 DevHelp::Date::dh_parse_date($data->{$key}, \$msg)) {
2031 $article->set($key, sprintf("%04d-%02d-%02d", $year, $month, $day));
59fca225
TC
2032 }
2033 else {
2034 $article->set($key => undef);
2035 }
2036 }
2037 elsif ($key =~ /^customInt/) {
2038 if ($data->{$key} =~ /\S/) {
2039 $article->set($key => $data->{$key});
2040 }
2041 else {
2042 $article->set($key => undef);
2043 }
2044 }
2045 else {
2046 $article->set($key => $data->{$key});
2047 }
2048 }
2049 }
331fd099
TC
2050 custom_class($self->{cfg})
2051 ->article_fill_old($article, $data, $self->typename);
ca9aa2bf
TC
2052
2053 return 1;
2054}
2055
8f88bb20
TC
2056sub _article_data {
2057 my ($self, $req, $article) = @_;
2058
2059 my $article_data = $article->data_only;
2060 $article_data->{link} = $article->link($req->cfg);
2061 $article_data->{images} =
2062 [
ca6c0ac9 2063 map $self->_image_data($req->cfg, $_), $article->images
8f88bb20
TC
2064 ];
2065 $article_data->{files} =
2066 [
2067 map $_->data_only, $article->files,
2068 ];
76c6b28e
TC
2069 $article_data->{tags} =
2070 [
2071 $article->tags, # just the names
2072 ];
8f88bb20
TC
2073
2074 return $article_data;
2075}
2076
dfd483db
TC
2077sub save_more {
2078 my ($self, $req, $article, $data) = @_;
2079 # nothing to do here
2080}
2081
2082sub save_new_more {
2083 my ($self, $req, $article, $data) = @_;
2084 # nothing to do here
2085}
2086
bf149413
TC
2087=item save
2088
2089Error codes:
2090
2091=over
2092
2093=item *
2094
2095ACCESS - user doesn't have access to this article.
2096
2097=item *
2098
2099LASTMOD - lastModified value doesn't match that in the article
2100
2101=item *
2102
2103PARENT - invalid parentid specified
2104
2105=back
2106
2107=cut
2108
ca9aa2bf
TC
2109sub save {
2110 my ($self, $req, $article, $articles) = @_;
4010d92e 2111
aa6896b6
TC
2112 $req->check_csrf("admin_save_article")
2113 or return $self->csrf_error($req, $article, "admin_save_article", "Save Article");
2114
4010d92e 2115 $req->user_can(edit_save => $article)
bf149413
TC
2116 or return $self->_service_error
2117 ($req, $article, $articles, "You don't have access to save this article",
2118 {}, "ACCESS");
efcc5a30
TC
2119
2120 my $old_dynamic = $article->is_dynamic;
ca9aa2bf
TC
2121 my $cgi = $req->cgi;
2122 my %data;
dfd483db
TC
2123 my $table_object = $self->table_object($articles);
2124 my @save_cols = $self->save_columns($table_object);
2125 for my $name (@save_cols) {
ca9aa2bf 2126 $data{$name} = $cgi->param($name)
abf5bbc6
TC
2127 if defined($cgi->param($name)) and $name ne 'id' && $name ne 'parentid'
2128 && $req->user_can("edit_field_edit_$name", $article);
ca9aa2bf 2129 }
12b42a0b
TC
2130
2131# Added by adrian
2132# checks editor lastModified against record lastModified
2133 if ($self->{cfg}->entry('editor', 'check_modified')) {
2134 if ($article->{lastModified} ne $cgi->param('lastModified')) {
2135 my $whoModified = '';
2136 my $timeModified = ampm_time($article->{lastModified});
2137 if ($article->{lastModifiedBy}) {
2138 $whoModified = "by '$article->{lastModifiedBy}'";
2139 }
2140 print STDERR "non-matching lastModified, article not saved\n";
2141 my $msg = "Article changes not saved, this article was modified $whoModified at $timeModified since this editor was loaded";
bf149413 2142 return $self->_service_error($req, $article, $articles, $msg, {}, "LASTMOD");
12b42a0b
TC
2143 }
2144 }
2145# end adrian
2146
918735d1
TC
2147 # possibly this needs tighter error checking
2148 $data{flags} = join '', sort $cgi->param('flags')
2149 if $req->user_can("edit_field_edit_flags", $article);
ca9aa2bf 2150 my %errors;
bf149413
TC
2151 if (exists $article->{template} &&
2152 $article->{template} =~ m|\.\.|) {
2153 $errors{template} = "Please only select templates from the list provided";
2154 }
76c6b28e 2155
b4c02bf9
TC
2156 my $meta;
2157 if ($cgi->param("_save_meta")) {
2158 require BSE::ArticleMetaMeta;
2159 $meta = BSE::ArticleMetaMeta->retrieve($req, $article, \%errors);
2160 }
2161
76c6b28e
TC
2162 my $save_tags = $cgi->param("_save_tags");
2163 my @tags;
2164 if ($save_tags) {
c46eae4a
TC
2165 @tags = $cgi->param("tags");
2166 $self->_validate_tags(\@tags, \%errors);
76c6b28e 2167 }
8f88bb20 2168 $self->validate_old($article, \%data, $articles, \%errors, scalar $req->is_ajax)
bf149413 2169 or return $self->_service_error($req, $article, $articles, undef, \%errors, "FIELD");
abf5bbc6
TC
2170 $self->save_thumbnail($cgi, $article, \%data)
2171 if $req->user_can('edit_field_edit_thumbImage', $article);
70c6e1e1 2172 if (exists $data{flags} && $data{flags} =~ /D/) {
a739c25d
TC
2173 $article->remove_html;
2174 }
ca9aa2bf 2175 $self->fill_old_data($req, $article, \%data);
12b42a0b 2176
ca9aa2bf
TC
2177 # reparenting
2178 my $newparentid = $cgi->param('parentid');
6d91d9dc
TC
2179 if ($newparentid
2180 && $req->user_can('edit_field_edit_parentid', $article)
2181 && $newparentid != $article->{parentid}) {
2182 my $newparent;
2183 my $parent_editor;
2184 if ($newparentid == -1) {
2185 require BSE::Edit::Site;
2186 $newparent = BSE::TB::Site->new;
2187 $parent_editor = BSE::Edit::Site->new(cfg => $req->cfg);
abf5bbc6 2188 }
6d91d9dc
TC
2189 else {
2190 $newparent = $articles->getByPkey($newparentid);
2191 ($parent_editor, $newparent) = $self->article_class($newparent, $articles, $req->cfg);
2192 }
2193 if ($newparent) {
2194 my $msg;
2195 if ($self->can_reparent_to($article, $newparent, $parent_editor, $articles, \$msg)
2196 && $self->reparent($article, $newparentid, $articles, \$msg)) {
2197 # nothing to do here
2198 }
2199 else {
2200 return $self->_service_error($req, $article, $articles, $msg, {}, "PARENT");
ca9aa2bf 2201 }
abf5bbc6
TC
2202 }
2203 else {
6d91d9dc 2204 return $self->_service_error($req, $article, $articles, "No such parent article", {}, "PARENT");
ca9aa2bf 2205 }
ca9aa2bf
TC
2206 }
2207
abf5bbc6 2208 $article->{listed} = $cgi->param('listed')
63e99d77 2209 if defined $cgi->param('listed') &&
abf5bbc6 2210 $req->user_can('edit_field_edit_listed', $article);
8f88bb20
TC
2211
2212 if ($req->user_can('edit_field_edit_release', $article)) {
2213 my $release = $cgi->param("release");
2214 if (defined $release && $release =~ /\S/) {
2215 if ($req->is_ajax) {
2216 $article->{release} = $release;
2217 }
2218 else {
2219 $article->{release} = sql_date($release)
2220 }
2221 }
2222 }
2223
abf5bbc6
TC
2224 $article->{expire} = sql_date($cgi->param('expire')) || $Constants::D_99
2225 if defined $cgi->param('expire') &&
2226 $req->user_can('edit_field_edit_expire', $article);
c2096d67
TC
2227 for my $col (qw/force_dynamic inherit_siteuser_rights/) {
2228 if ($req->user_can("edit_field_edit_$col", $article)
2229 && $cgi->param("save_$col")) {
2230 $article->{$col} = $cgi->param($col) ? 1 : 0;
2231 }
2232 }
2233
46e71678 2234 $article->mark_modified(actor => $req->getuser || "U");
c2096d67
TC
2235
2236 my @save_group_ids = $cgi->param('save_group_id');
2237 if ($req->user_can('edit_field_edit_group_id')
2238 && @save_group_ids) {
2239 require BSE::TB::SiteUserGroups;
2240 my %groups = map { $_->{id} => $_ }
2241 BSE::TB::SiteUserGroups->admin_and_query_groups($self->{cfg});
2242 my %set = map { $_ => 1 } $cgi->param('group_id');
2243 my %current = map { $_ => 1 } $article->group_ids;
2244
2245 for my $group_id (@save_group_ids) {
2246 $groups{$group_id} or next;
2247 if ($current{$group_id} && !$set{$group_id}) {
2248 $article->remove_group_id($group_id);
2249 }
2250 elsif (!$current{$group_id} && $set{$group_id}) {
2251 $article->add_group_id($group_id);
2252 }
2253 }
efcc5a30
TC
2254 }
2255
63e99d77 2256 my $old_link = $article->{link};
efcc5a30
TC
2257 # this need to go last
2258 $article->update_dynamic($self->{cfg});
a739c25d 2259 if (!$self->{cfg}->entry('protect link', $article->{id})) {
95989433 2260 my $article_uri = $self->make_link($article);
95989433 2261 $article->setLink($article_uri);
ca9aa2bf
TC
2262 }
2263
2264 $article->save();
caa7299c 2265
76c6b28e
TC
2266 if ($save_tags) {
2267 my $error;
c46eae4a 2268 $article->set_tags([ grep /\S/, @tags ], \$error);
76c6b28e
TC
2269 }
2270
b4c02bf9
TC
2271use Data::Dumper;
2272print STDERR Dumper($meta);
2273 if ($meta) {
2274 BSE::ArticleMetaMeta->save($article, $meta);
2275 }
2276
63e99d77 2277 # fix the kids too
efcc5a30 2278 my @extra_regen;
63e99d77
TC
2279 @extra_regen = $self->update_child_dynamic($article, $articles, $req);
2280
2281 if ($article->is_dynamic || $old_dynamic) {
2282 if (!$old_dynamic and $old_link) {
2283 unlink $article->link_to_filename($self->{cfg}, $old_link);
2284 }
16901a2a
TC
2285 elsif (!$article->is_dynamic) {
2286 unlink $article->cached_filename($self->{cfg});
2287 }
efcc5a30
TC
2288 }
2289
91fad97a
TC
2290 my ($after_id) = $cgi->param("_after");
2291 if (defined $after_id) {
e0ed81d7 2292 BSE::TB::Articles->reorder_child($article->{parentid}, $article->{id}, $after_id);
91fad97a
TC
2293 # reload, the displayOrder probably changed
2294 $article = $articles->getByPkey($article->{id});
2295 }
2296
efcc5a30
TC
2297 if ($Constants::AUTO_GENERATE) {
2298 generate_article($articles, $article);
2299 for my $regen_id (@extra_regen) {
2300 my $regen = $articles->getByPkey($regen_id);
f48fc7cf 2301 BSE::Regen::generate_low($articles, $regen, $self->{cfg});
efcc5a30
TC
2302 }
2303 }
caa7299c 2304
dfd483db
TC
2305 $self->save_more($req, $article, \%data);
2306
8f88bb20
TC
2307 if ($req->is_ajax) {
2308 return $req->json_content
2309 (
2310 {
2311 success => 1,
2312 article => $self->_article_data($req, $article),
2313 },
2314 );
2315 }
2316
8b0b2f34 2317 return $self->refresh($article, $cgi, undef, 'Article saved');
ca9aa2bf
TC
2318}
2319
6d91d9dc
TC
2320sub can_reparent_to {
2321 my ($self, $article, $newparent, $parent_editor, $articles, $rmsg) = @_;
2322
6d91d9dc
TC
2323 my @child_types = $parent_editor->child_types;
2324 if (!grep $_ eq ref $self, @child_types) {
2325 my ($child_type) = (ref $self) =~ /(\w+)$/;
2326 my ($parent_type) = (ref $parent_editor) =~ /(\w+)$/;
2327
2328 $$rmsg = "A $child_type cannot be a child of a $parent_type";
2329 return;
2330 }
2331
2332 # the article cannot become a child of itself or one of it's
2333 # children
2334 if ($article->{id} == $newparent->id
2335 || $self->is_descendant($article->id, $newparent->id, $articles)) {
2336 $$rmsg = "Cannot become a child of itself or of a descendant";
2337 return;
2338 }
2339
2340 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2341 if ($self->shop_article) { # if this article belongs in the shop
2342 unless ($newparent->id == $shopid
2343 || $self->is_descendant($shopid, $newparent->{id}, $articles)) {
2344 $$rmsg = "This article belongs in the shop";
2345 return;
2346 }
2347 }
2348 else {
2349 if ($newparent->id == $shopid
2350 || $self->is_descendant($shopid, $newparent->id, $articles)) {
2351 $$rmsg = "This article doesn't belong in the shop";
2352 return;
2353 }
2354 }
2355
2356 return 1;
2357}
2358
2359sub shop_article { 0 }
2360
efcc5a30
TC
2361sub update_child_dynamic {
2362 my ($self, $article, $articles, $req) = @_;
2363
2364 my $cfg = $req->cfg;
2365 my @stack = $article->children;
2366 my @regen;
2367 while (@stack) {
2368 my $workart = pop @stack;
2369 my $old_dynamic = $workart->is_dynamic; # before update
63e99d77 2370 my $old_link = $workart->{link};
3e37b5ba
TC
2371 my $editor;
2372 ($editor, $workart) = $self->article_class($workart, $articles, $cfg);
2373
efcc5a30
TC
2374 $workart->update_dynamic($cfg);
2375 if ($old_dynamic != $workart->is_dynamic) {
2376 # update the link
2377 if ($article->{link} && !$cfg->entry('protect link', $workart->{id})) {
efcc5a30
TC
2378 my $uri = $editor->make_link($workart);
2379 $workart->setLink($uri);
63e99d77 2380
8f84f3f1
TC
2381 !$old_dynamic && $old_link
2382 and unlink $workart->link_to_filename($cfg, $old_link);
2383 $workart->is_dynamic
16901a2a 2384 or unlink $workart->cached_filename($cfg);
efcc5a30
TC
2385 }
2386
2387 # save dynamic cache change and link if that changed
2388 $workart->save;
2389 }
2390 push @stack, $workart->children;
2391 push @regen, $workart->{id};
2392 }
2393
2394 @regen;
2395}
2396
ca9aa2bf
TC
2397sub sql_date {
2398 my $str = shift;
2399 my ($year, $month, $day);
2400
2401 # look for a date
2402 if (($day, $month, $year) = ($str =~ m!(\d+)/(\d+)/(\d+)!)) {
2403 $year += 2000 if $year < 100;
2404
2405 return sprintf("%04d-%02d-%02d", $year, $month, $day);
2406 }
2407 return undef;
2408}
2409
12b42a0b
TC
2410# Added by adrian
2411# Converts 24hr time to 12hr AM/PM time
2412sub ampm_time {
2413 my $str = shift;
2414 my ($hour, $minute, $second, $ampm);
2415
2416 # look for a time
2417 if (($hour, $minute, $second) = ($str =~ m!(\d+):(\d+):(\d+)!)) {
2418 if ($hour > 12) {
2419 $hour -= 12;
2420 $ampm = 'PM';
2421 }
2422 else {
c2096d67 2423 $hour = 12 if $hour == 0;
12b42a0b
TC
2424 $ampm = 'AM';
2425 }
2426 return sprintf("%02d:%02d:%02d $ampm", $hour, $minute, $second);
2427 }
2428 return undef;
2429}
2430# end adrian
2431
ca9aa2bf
TC
2432sub reparent {
2433 my ($self, $article, $newparentid, $articles, $rmsg) = @_;
2434
2435 my $newlevel;
2436 if ($newparentid == -1) {
2437 $newlevel = 1;
2438 }
2439 else {
2440 my $parent = $articles->getByPkey($newparentid);
2441 unless ($parent) {
2442 $$rmsg = "Cannot get new parent article";
2443 return;
2444 }
2445 $newlevel = $parent->{level} + 1;
2446 }
2447 # the caller will save this one
2448 $article->{parentid} = $newparentid;
2449 $article->{level} = $newlevel;
2450 $article->{displayOrder} = time;
2451
2452 my @change = ( [ $article->{id}, $newlevel ] );
2453 while (@change) {
2454 my $this = shift @change;
2455 my ($art, $level) = @$this;
2456
2457 my @kids = $articles->getBy(parentid=>$art);
2458 push @change, map { [ $_->{id}, $level+1 ] } @kids;
2459
2460 for my $kid (@kids) {
2461 $kid->{level} = $level+1;
2462 $kid->save;
2463 }
2464 }
2465
2466 return 1;
2467}
2468
2469# tests if $desc is a descendant of $art
2470# where both are article ids
2471sub is_descendant {
2472 my ($self, $art, $desc, $articles) = @_;
2473
2474 my @check = ($art);
2475 while (@check) {
2476 my $parent = shift @check;
2477 $parent == $desc and return 1;
2478 my @kids = $articles->getBy(parentid=>$parent);
2479 push @check, map $_->{id}, @kids;
2480 }
2481
2482 return 0;
2483}
2484
2485sub save_thumbnail {
2486 my ($self, $cgi, $original, $newdata) = @_;
2487
2488 unless ($original) {
2489 @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2490 }
ab2cd916 2491 my $imagedir = cfg_image_dir($self->{cfg});
ca9aa2bf
TC
2492 if ($cgi->param('remove_thumb') && $original && $original->{thumbImage}) {
2493 unlink("$imagedir/$original->{thumbImage}");
2494 @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
2495 }
3f9c8a96
TC
2496 my $image_name = $cgi->param('thumbnail');
2497 my $image = $cgi->upload('thumbnail');
2498 if ($image_name && -s $image) {
ca9aa2bf
TC
2499 # where to put it...
2500 my $name = '';
3f9c8a96 2501 $image_name =~ /([\w.-]+)$/ and $name = $1;
ca9aa2bf
TC
2502 my $filename = time . "_" . $name;
2503
2504 use Fcntl;
2505 my $counter = "";
2506 $filename = time . '_' . $counter . '_' . $name
2507 until sysopen( OUTPUT, "$imagedir/$filename",
2508 O_WRONLY| O_CREAT| O_EXCL)
2509 || ++$counter > 100;
2510
2511 fileno(OUTPUT) or die "Could not open image file: $!";
2512 binmode OUTPUT;
2513 my $buffer;
2514
2515 #no strict 'refs';
2516
2517 # read the image in from the browser and output it to our
2518 # output filehandle
2519 print STDERR "\$image ",ref $image,"\n";
2520 seek $image, 0, 0;
2521 print OUTPUT $buffer while sysread $image, $buffer, 1024;
2522
2523 close OUTPUT
2524 or die "Could not close image output file: $!";
2525
ea0b8f8e 2526 require BSE::ImageSize;
ca9aa2bf
TC
2527
2528 if ($original && $original->{thumbImage}) {
2529 #unlink("$imagedir/$original->{thumbImage}");
2530 }
ea0b8f8e
TC
2531 @$newdata{qw/thumbWidth thumbHeight/} =
2532 BSE::ImageSize::imgsize("$imagedir/$filename");
ca9aa2bf
TC
2533 $newdata->{thumbImage} = $filename;
2534 }
2535}
2536
2537sub child_types {
2538 my ($self, $article) = @_;
2539
2540 my $shopid = $self->{cfg}->entryErr('articles', 'shop');
2541 if ($article && $article->{id} && $article->{id} == $shopid) {
2542 return ( 'BSE::Edit::Catalog' );
2543 }
2544 return ( 'BSE::Edit::Article' );
2545}
2546
0b2a3da0
TC
2547=item add_stepkid
2548
2549Add a step child to an article.
2550
2551Parameters:
2552
2553=over
2554
2555=item *
2556
2557id - parent article id (required)
2558
2559=item *
2560
2561stepkid - child article id (required)
2562
2563=item *
2564
2565_after - id of the allkid of id to position the stepkid after
2566(optional)
2567
2568=back
2569
2570Returns a FIELD error for an invalid stepkid.
2571
2572Returns an ACCESS error for insufficient access.
2573
2574Return an ADD error for a general add failure.
2575
2576On success returns:
2577
2578 {
2579 success: 1,
2580 relationship: { childId: I<childid>, parentId: I<parentid> }
2581 }
2582
2583=back
2584
2585=cut
2586
ca9aa2bf
TC
2587sub add_stepkid {
2588 my ($self, $req, $article, $articles) = @_;
2589
aa6896b6
TC
2590 $req->check_csrf("admin_add_stepkid")
2591 or return $self->csrf_error($req, $article, "admin_add_stepkid", "Add Stepkid");
2592
31a26b52 2593 $req->user_can(edit_stepkid_add => $article)
0b2a3da0
TC
2594 or return $self->_service_error($req, $article, $articles,
2595 "You don't have access to add step children to this article", {}, "ACCESS");
31a26b52 2596
ca9aa2bf 2597 my $cgi = $req->cgi;
0b2a3da0
TC
2598 require BSE::Admin::StepParents;
2599
2600 my %errors;
2601 my $childId = $cgi->param('stepkid');
2602 defined $childId
2603 or $errors{stepkid} = "No stepkid supplied to add_stepkid";
2604 unless ($errors{stepkid}) {
ca9aa2bf 2605 $childId =~ /^\d+$/
0b2a3da0
TC
2606 or $errors{stepkid} = "Invalid stepkid supplied to add_stepkid";
2607 }
2608 my $child;
2609 unless ($errors{stepkid}) {
2610 $child = $articles->getByPkey($childId)
2611 or $errors{stepkid} = "Article $childId not found";
2612 }
2613 keys %errors
2614 and return $self->_service_error
2615 ($req, $article, $articles, $errors{stepkid}, \%errors, "FIELD");
31a26b52 2616
0b2a3da0
TC
2617 $req->user_can(edit_stepparent_add => $child)
2618 or return $self->_service_error($req, $article, $articles, "You don't have access to add a stepparent to that article", {}, "ACCESS");
2619
2620 my $new_entry;
2621 eval {
ca9aa2bf 2622
ca9aa2bf 2623 my $release = $cgi->param('release');
8f88bb20 2624 dh_parse_date($release) or $release = undef;
ca9aa2bf 2625 my $expire = $cgi->param('expire');
8f88bb20 2626 dh_parse_date($expire) or $expire = undef;
ca9aa2bf 2627
0b2a3da0 2628 $new_entry =
ca9aa2bf
TC
2629 BSE::Admin::StepParents->add($article, $child, $release, $expire);
2630 };
2631 if ($@) {
0b2a3da0
TC
2632 return $self->_service_error($req, $article, $articles, $@, {}, "ADD");
2633 }
2634
2635 my $after_id = $cgi->param("_after");
2636 if (defined $after_id) {
e0ed81d7 2637 BSE::TB::Articles->reorder_child($article->id, $child->id, $after_id);
ca9aa2bf 2638 }
a0a8147b 2639
a0a8147b
TC
2640 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2641
0b2a3da0
TC
2642 if ($req->is_ajax) {
2643 return $req->json_content
2644 (
2645 success => 1,
2646 relationship => $new_entry->data_only,
2647 );
2648 }
2649 else {
2650 $self->refresh($article, $cgi, 'step', 'Stepchild added');
2651 }
ca9aa2bf
TC
2652}
2653
0b2a3da0
TC
2654=item del_stepkid
2655
2656Remove a stepkid relationship.
2657
2658Parameters:
2659
2660=over
2661
2662=item *
2663
2664id - parent article id (required)
2665
2666=item *
2667
2668stepkid - child article id (required)
2669
2670=back
2671
2672Returns a FIELD error for an invalid stepkid.
2673
2674Returns an ACCESS error for insufficient access.
2675
2676Return a DELETE error for a general delete failure.
2677
2678=cut
2679
ca9aa2bf
TC
2680sub del_stepkid {
2681 my ($self, $req, $article, $articles) = @_;
2682
aa6896b6
TC
2683 $req->check_csrf("admin_remove_stepkid")
2684 or return $self->csrf_error($req, $article, "admin_del_stepkid", "Delete Stepkid");
31a26b52 2685 $req->user_can(edit_stepkid_delete => $article)
0b2a3da0
TC
2686 or return $self->_service_error($req, $article, $articles,
2687 "You don't have access to delete stepchildren from this article", {}, "ACCESS");
31a26b52 2688
ca9aa2bf 2689 my $cgi = $req->cgi;
0b2a3da0
TC
2690
2691 my %errors;
2692 my $childId = $cgi->param('stepkid');
2693 defined $childId
2694 or $errors{stepkid} = "No stepkid supplied to add_stepkid";
2695 unless ($errors{stepkid}) {
ca9aa2bf 2696 $childId =~ /^\d+$/
0b2a3da0
TC
2697 or $errors{stepkid} = "Invalid stepkid supplied to add_stepkid";
2698 }
2699 my $child;
2700 unless ($errors{stepkid}) {
2701 $child = $articles->getByPkey($childId)
2702 or $errors{stepkid} = "Article $childId not found";
2703 }
2704 keys %errors
2705 and return $self->_service_error
2706 ($req, $article, $articles, $errors{stepkid}, \%errors, "FIELD");
31a26b52 2707
0b2a3da0
TC
2708 $req->user_can(edit_stepparent_delete => $child)
2709 or return _service_error($req, $article, $article, "You cannot remove stepparents from that article", {}, "ACCESS");
ca9aa2bf 2710
0b2a3da0
TC
2711
2712 require BSE::Admin::StepParents;
2713 eval {
ca9aa2bf
TC
2714 BSE::Admin::StepParents->del($article, $child);
2715 };
2716
2717 if ($@) {
0b2a3da0 2718 return $self->_service_error($req, $article, $articles, $@, {}, "DELETE");
ca9aa2bf 2719 }
a0a8147b
TC
2720 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2721
0b2a3da0
TC
2722 if ($req->is_ajax) {
2723 return $req->json_content(success => 1);
2724 }
2725 else {
2726 return $self->refresh($article, $cgi, 'step', 'Stepchild deleted');
2727 }
ca9aa2bf
TC
2728}
2729
2730sub save_stepkids {
2731 my ($self, $req, $article, $articles) = @_;
2732
aa6896b6
TC
2733 $req->check_csrf("admin_save_stepkids")
2734 or return $self->csrf_error($req, $article, "admin_save_stepkids", "Save Stepkids");
2735
31a26b52
TC
2736 $req->user_can(edit_stepkid_save => $article)
2737 or return $self->edit_form($req, $article, $articles,
2738 "No access to save stepkid data for this article");
2739
ca9aa2bf
TC
2740 my $cgi = $req->cgi;
2741 require 'BSE/Admin/StepParents.pm';
0c2d3f00 2742 my @stepcats = BSE::TB::OtherParents->getBy(parentId=>$article->{id});
ca9aa2bf
TC
2743 my %stepcats = map { $_->{parentId}, $_ } @stepcats;
2744 my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2745 for my $stepcat (@stepcats) {
31a26b52
TC
2746 $req->user_can(edit_stepparent_save => $stepcat->{childId})
2747 or next;
ca9aa2bf
TC
2748 for my $name (qw/release expire/) {
2749 my $date = $cgi->param($name.'_'.$stepcat->{childId});
2750 if (defined $date) {
2751 if ($date eq '') {
2752 $date = $datedefs{$name};
2753 }
8f88bb20 2754 elsif (dh_parse_date($date)) {
ca9aa2bf
TC
2755 use BSE::Util::SQL qw/date_to_sql/;
2756 $date = date_to_sql($date);
2757 }
2758 else {
2759 return $self->refresh($article, $cgi, '', "Invalid date '$date'");
2760 }
2761 $stepcat->{$name} = $date;
2762 }
2763 }
2764 eval {
2765 $stepcat->save();
2766 };
2767 $@ and return $self->refresh($article, $cgi, '', $@);
2768 }
a0a8147b
TC
2769 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2770
8b0b2f34 2771 return $self->refresh($article, $cgi, 'step', 'Stepchild information saved');
ca9aa2bf
TC
2772}
2773
8634bfaa
TC
2774=item a_restepkid
2775
2776Moves a stepkid from one parent to another, and sets the order within
2777that new stepparent.
2778
2779Parameters:
2780
2781=over
2782
2783=item *
2784
2785id - id of the step kid to move (required)
2786
2787=item *
2788
2789parentid - id of the parent in the stepkid relationship (required)
2790
2791=item *
2792
2793newparentid - the new parent for the stepkid relationship (optional)
2794
2795=item *
2796
2797_after - id of the allkid under newparentid (or parentid if
2798newparentid isn't supplied) to place the stepkid after (0 to place at
2799the start)
2800
2801=back
2802
2803Errors:
2804
2805=over
2806
2807=item *
2808
2809NOPARENTID - parentid parameter not supplied
2810
2811=item *
2812
2813BADPARENTID - non-numeric parentid supplied
2814
2815=item *
2816
2817NOTFOUND - no stepkid relationship from parentid was found
2818
2819=item *
2820
2821BADNEWPARENT - newparentid is non-numeric
2822
2823=item *
2824
2825UNKNOWNNEWPARENT - no article id newparentid found
2826
2827=item *
2828
2829NEWPARENTDUP - there's already a stepkid relationship between
2830newparentid and id.
2831
2832=back
2833
2834=cut
2835
2836sub req_restepkid {
2837 my ($self, $req, $article, $articles) = @_;
2838
2839 # first, identify the stepkid link
2840 my $cgi = $req->cgi;
0c2d3f00 2841 require BSE::TB::OtherParents;
8634bfaa
TC
2842 my $parentid = $cgi->param("parentid");
2843 defined $parentid
2844 or return $self->_service_error($req, $article, $articles, "Missing parentid", {}, "NOPARENTID");
2845 $parentid =~ /^\d+$/
2846 or return $self->_service_error($req, $article, $articles, "Invalid parentid", {}, "BADPARENTID");
2847
0c2d3f00 2848 my ($step) = BSE::TB::OtherParents->getBy(parentId => $parentid, childId => $article->id)
8634bfaa
TC
2849 or return $self->_service_error($req, $article, $articles, "Unknown relationship", {}, "NOTFOUND");
2850
2851 my $newparentid = $cgi->param("newparentid");
2852 if ($newparentid) {
2853 $newparentid =~ /^\d+$/
2854 or return $self->_service_error($req, $article, $articles, "Bad new parent id", {}, "BADNEWPARENT");
e0ed81d7 2855 my $new_parent = BSE::TB::Articles->getByPkey($newparentid)
8634bfaa
TC
2856 or return $self->_service_error($req, $article, $articles, "Unknown new parent id", {}, "UNKNOWNNEWPARENT");
2857 my $existing =
0c2d3f00 2858 BSE::TB::OtherParents->getBy(parentId=>$newparentid, childId=>$article->id)
8634bfaa
TC
2859 and return $self->_service_error($req, $article, $articles, "New parent is duplicate", {}, "NEWPARENTDUP");
2860
2861 $step->{parentId} = $newparentid;
2862 $step->save;
2863 }
2864
2865 my $after_id = $cgi->param("_after");
2866 if (defined $after_id) {
e0ed81d7 2867 BSE::TB::Articles->reorder_child($step->{parentId}, $article->id, $after_id);
8634bfaa
TC
2868 }
2869
2870 if ($req->is_ajax) {
2871 return $req->json_content
2872 (
2873 success => 1,
2874 relationshop => $step->data_only,
2875 );
2876 }
2877 else {
2878 return $self->refresh($article, $cgi, 'step', "Stepchild moved");
2879 }
2880}
2881
ca9aa2bf
TC
2882sub add_stepparent {
2883 my ($self, $req, $article, $articles) = @_;
2884
aa6896b6
TC
2885 $req->check_csrf("admin_add_stepparent")
2886 or return $self->csrf_error($req, $article, "admin_add_stepparent", "Add Stepparent");
2887
31a26b52
TC
2888 $req->user_can(edit_stepparent_add => $article)
2889 or return $self->edit_form($req, $article, $articles,
2890 "You don't have access to add stepparents to this article");
2891
ca9aa2bf
TC
2892 my $cgi = $req->cgi;
2893 require 'BSE/Admin/StepParents.pm';
2894 eval {
2895 my $step_parent_id = $cgi->param('stepparent');
2896 defined($step_parent_id)
2897 or die "No stepparent supplied to add_stepparent";
2898 int($step_parent_id) eq $step_parent_id
2899 or die "Invalid stepcat supplied to add_stepcat";
2900 my $step_parent = $articles->getByPkey($step_parent_id)
31a26b52
TC
2901 or die "Parent $step_parent_id not found\n";
2902
2903 $req->user_can(edit_stepkid_add => $step_parent)
2904 or die "You don't have access to add a stepkid to that article\n";
ca9aa2bf
TC
2905
2906 my $release = $cgi->param('release');
2907 defined $release
2908 or $release = "01/01/2000";
8f88bb20 2909 $release eq '' or dh_parse_date($release)
ca9aa2bf
TC
2910 or die "Invalid release date";
2911 my $expire = $cgi->param('expire');
2912 defined $expire
2913 or $expire = '31/12/2999';
8f88bb20 2914 $expire eq '' or dh_parse_date($expire)
ca9aa2bf
TC
2915 or die "Invalid expire data";
2916
2917 my $newentry =
2918 BSE::Admin::StepParents->add($step_parent, $article, $release, $expire);
2919 };
2920 $@ and return $self->refresh($article, $cgi, 'step', $@);
2921
a0a8147b
TC
2922 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2923
8b0b2f34 2924 return $self->refresh($article, $cgi, 'stepparents', 'Stepparent added');
ca9aa2bf
TC
2925}
2926
2927sub del_stepparent {
2928 my ($self, $req, $article, $articles) = @_;
2929
aa6896b6
TC
2930 $req->check_csrf("admin_remove_stepparent")
2931 or return $self->csrf_error($req, $article, "admin_del_stepparent", "Delete Stepparent");
2932
31a26b52
TC
2933 $req->user_can(edit_stepparent_delete => $article)
2934 or return $self->edit_form($req, $article, $articles,
2935 "You cannot remove stepparents from that article");
2936
ca9aa2bf
TC
2937 my $cgi = $req->cgi;
2938 require 'BSE/Admin/StepParents.pm';
2939 my $step_parent_id = $cgi->param('stepparent');
2940 defined($step_parent_id)
2941 or return $self->refresh($article, $cgi, 'stepparents',
2942 "No stepparent supplied to add_stepcat");
2943 int($step_parent_id) eq $step_parent_id
2944 or return $self->refresh($article, $cgi, 'stepparents',
2945 "Invalid stepparent supplied to add_stepparent");
2946 my $step_parent = $articles->getByPkey($step_parent_id)
2947 or return $self->refresh($article, $cgi, 'stepparent',
2948 "Stepparent $step_parent_id not found");
2949
31a26b52
TC
2950 $req->user_can(edit_stepkid_delete => $step_parent)
2951 or die "You don't have access to remove the stepkid from that article\n";
2952
ca9aa2bf
TC
2953 eval {
2954 BSE::Admin::StepParents->del($step_parent, $article);
2955 };
2956 $@ and return $self->refresh($article, $cgi, 'stepparents', $@);
2957
a0a8147b
TC
2958 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
2959
8b0b2f34 2960 return $self->refresh($article, $cgi, 'stepparents', 'Stepparent deleted');
ca9aa2bf
TC
2961}
2962
2963sub save_stepparents {
2964 my ($self, $req, $article, $articles) = @_;
2965
aa6896b6
TC
2966 $req->check_csrf("admin_save_stepparents")
2967 or return $self->csrf_error($req, $article, "admin_save_stepparents", "Save Stepparents");
31a26b52
TC
2968 $req->user_can(edit_stepparent_save => $article)
2969 or return $self->edit_form($req, $article, $articles,
2970 "No access to save stepparent data for this artice");
2971
ca9aa2bf
TC
2972 my $cgi = $req->cgi;
2973
2974 require 'BSE/Admin/StepParents.pm';
0c2d3f00 2975 my @stepparents = BSE::TB::OtherParents->getBy(childId=>$article->{id});
ca9aa2bf
TC
2976 my %stepparents = map { $_->{parentId}, $_ } @stepparents;
2977 my %datedefs = ( release => '2000-01-01', expire=>'2999-12-31' );
2978 for my $stepparent (@stepparents) {
31a26b52
TC
2979 $req->user_can(edit_stepkid_save => $stepparent->{parentId})
2980 or next;
ca9aa2bf
TC
2981 for my $name (qw/release expire/) {
2982 my $date = $cgi->param($name.'_'.$stepparent->{parentId});
2983 if (defined $date) {
2984 if ($date eq '') {
2985 $date = $datedefs{$name};
2986 }
8f88bb20 2987 elsif (dh_parse_date($date)) {
ca9aa2bf
TC
2988 use BSE::Util::SQL qw/date_to_sql/;
2989 $date = date_to_sql($date);
2990 }
2991 else {
2992 return $self->refresh($article, $cgi, "Invalid date '$date'");
2993 }
2994 $stepparent->{$name} = $date;
2995 }
2996 }
2997 eval {
2998 $stepparent->save();
2999 };
3000 $@ and return $self->refresh($article, $cgi, '', $@);
3001 }
3002
a0a8147b
TC
3003 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3004
8b0b2f34
TC
3005 return $self->refresh($article, $cgi, 'stepparents',
3006 'Stepparent information saved');
ca9aa2bf
TC
3007}
3008
58baa27b 3009sub refresh_url {
ca9aa2bf
TC
3010 my ($self, $article, $cgi, $name, $message, $extras) = @_;
3011
8b0b2f34 3012 my $url = $cgi->param('r');
16ac5598
TC
3013 if ($url) {
3014 if ($url !~ /[?&](m|message)=/ && $message) {
3015 # add in messages if none in the provided refresh
3016 my @msgs = ref $message ? @$message : $message;
f3fc60c0 3017 my $sep = $url =~ /\?/ ? "&" : "?";
16ac5598 3018 for my $msg (@msgs) {
f3fc60c0 3019 $url .= $sep . "m=" . CGI::escape($msg);
16ac5598
TC
3020 }
3021 }
3022 }
3023 else {
41f10371 3024 my $urlbase = admin_base_url($self->{cfg});
8b0b2f34 3025 $url = "$urlbase$ENV{SCRIPT_NAME}?id=$article->{id}";
16ac5598
TC
3026 if ($message) {
3027 my @msgs = ref $message ? @$message : $message;
3028 for my $msg (@msgs) {
3029 $url .= "&m=" . CGI::escape($msg);
3030 }
3031 }
8b0b2f34
TC
3032 if ($cgi->param('_t')) {
3033 $url .= "&_t=".CGI::escape($cgi->param('_t'));
3034 }
3035 $url .= $extras if defined $extras;
3036 my $cgiextras = $cgi->param('e');
3037 $url .= "#$name" if $name;
ca9aa2bf 3038 }
ca9aa2bf 3039
58baa27b
TC
3040 return $url;
3041}
3042
3043sub refresh {
3044 my ($self, $article, $cgi, $name, $message, $extras) = @_;
3045
3046 my $url = $self->refresh_url($article, $cgi, $name, $message, $extras);
3047
ca9aa2bf
TC
3048 return BSE::Template->get_refresh($url, $self->{cfg});
3049}
3050
3051sub show_images {
918735d1 3052 my ($self, $req, $article, $articles, $msg, $errors) = @_;
ca9aa2bf
TC
3053
3054 my %acts;
918735d1 3055 %acts = $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors);
ca9aa2bf
TC
3056 my $template = 'admin/article_img';
3057
4d764c34 3058 return $req->dyn_response($template, \%acts);
ca9aa2bf
TC
3059}
3060
3061sub save_image_changes {
3062 my ($self, $req, $article, $articles) = @_;
3063
aa6896b6
TC
3064 $req->check_csrf("admin_save_images")
3065 or return $self->csrf_error($req, $article, "admin_save_images", "Save Images");
3066
abf5bbc6 3067 $req->user_can(edit_images_save => $article)
cc9019d1 3068 or return $self->edit_form($req, $article, $articles,
abf5bbc6
TC
3069 "You don't have access to save image information for this article");
3070
b95fc3a0
TC
3071 my $image_dir = cfg_image_dir($req->cfg);
3072
ca9aa2bf
TC
3073 my $cgi = $req->cgi;
3074 my $image_pos = $cgi->param('imagePos');
3075 if ($image_pos
1e60d3c4 3076 && $image_pos =~ /^(?:tl|tr|bl|br|xx)$/
ca9aa2bf
TC
3077 && $image_pos ne $article->{imagePos}) {
3078 $article->{imagePos} = $image_pos;
3079 $article->save;
3080 }
daee3409 3081 my @images = $self->get_images($article);
4772671f
TC
3082
3083 @images or
3084 return $self->refresh($article, $cgi, undef, 'No images to save information for');
ca9aa2bf 3085
b95fc3a0
TC
3086 my %changes;
3087 my %errors;
3088 my %names;
e63c3728 3089 my %old_images;
8326f275 3090 my @new_images;
b95fc3a0
TC
3091 for my $image (@images) {
3092 my $id = $image->{id};
3093
3094 my $alt = $cgi->param("alt$id");
3095 if ($alt ne $image->{alt}) {
3096 $changes{$id}{alt} = $alt;
ca9aa2bf 3097 }
b95fc3a0
TC
3098
3099 my $url = $cgi->param("url$id");
3100 if (defined $url && $url ne $image->{url}) {
3101 $changes{$id}{url} = $url;
ca9aa2bf 3102 }
b95fc3a0
TC
3103
3104 my $name = $cgi->param("name$id");
3105 if (defined $name && $name ne $image->{name}) {
547a26ad 3106 if ($name eq '') {
42c261c3 3107 $changes{$id}{name} = '';
2d83755d
TC
3108 }
3109 elsif ($name =~ /^[a-z_]\w*$/i) {
b95fc3a0
TC
3110 my $msg;
3111 if ($self->validate_image_name($name, \$msg)) {
3112 # check for duplicates after the loop
3113 push @{$names{lc $name}}, $image->{id}
3114 if length $name;
3115 $changes{$id}{name} = $name;
4772671f
TC
3116 }
3117 else {
b95fc3a0 3118 $errors{"name$id"} = $msg;
4772671f
TC
3119 }
3120 }
b95fc3a0
TC
3121 else {
3122 $errors{"name$id"} = 'Image name must be empty or alphanumeric and unique to the article';
3123 }
3124 }
3125 else {
3126 push @{$names{lc $image->{name}}}, $image->{id}
3127 if length $image->{name};
3128 }
3129
3130 my $filename = $cgi->param("image$id");
3131 if (defined $filename && length $filename) {
3132 my $in_fh = $cgi->upload("image$id");
3133 if ($in_fh) {
ec9b99b2
TC
3134 my $basename;
3135 my $image_error;
3136 my ($width, $height, $type) = $self->_validate_image
3137 ($filename, $in_fh, \$basename, \$image_error);
b95fc3a0 3138
ec9b99b2
TC
3139 unless ($type) {
3140 $errors{"image$id"} = $image_error;
3141 }
3142
3143 unless ($errors{"image$id"}) {
3144 # work out where to put it
3145 require DevHelp::FileUpload;
3146 my $msg;
3147 my ($image_name, $out_fh) = DevHelp::FileUpload->make_img_filename
3148 ($image_dir, $basename, \$msg);
3149 if ($image_name) {
3150 local $/ = \8192;
3151 my $data;
3152 while ($data = <$in_fh>) {
3153 print $out_fh $data;
3154 }
3155 close $out_fh;
3156
3157 my $full_filename = "$image_dir/$image_name";
3158 if ($width) {
3159 $old_images{$id} =
3160 {
3161 image => $image->{image},
3162 storage => $image->{storage}
3163 };
3164 push @new_images, $image_name;
3165
3166 $changes{$id}{image} = $image_name;
3167 $changes{$id}{storage} = 'local';
3168 $changes{$id}{src} = cfg_image_uri() . "/" . $image_name;
3169 $changes{$id}{width} = $width;
3170 $changes{$id}{height} = $height;
3171 $changes{$id}{ftype} = $self->_image_ftype($type);
3172 }
b95fc3a0
TC
3173 }
3174 else {
ec9b99b2 3175 $errors{"image$id"} = $msg;
b95fc3a0
TC
3176 }
3177 }
b95fc3a0
TC
3178 }
3179 else {
3180 # problem uploading
3181 $errors{"image$id"} = "No image file received";
3182 }
3183 }
3184 }
3185 # look for duplicate names
3186 for my $name (keys %names) {
3187 if (@{$names{$name}} > 1) {
3188 for my $id (@{$names{$name}}) {
3189 $errors{"name$id"} = 'Image name must be unique to the article';
daee3409 3190 }
4772671f
TC
3191 }
3192 }
8326f275
TC
3193 if (keys %errors) {
3194 # remove files that won't be stored because validation failed
3195 unlink map "$image_dir/$_", @new_images;
3196
3197 return $self->edit_form($req, $article, $articles, undef,
3198 \%errors);
3199 }
b95fc3a0 3200
e63c3728
TC
3201 my $mgr = $self->_image_manager($req->cfg);
3202 $req->flash('Image information saved');
3203 my $changes_found = 0;
3204 my $auto_store = $cgi->param('auto_storage');
3205 for my $image (@images) {
3206 my $id = $image->{id};
3207
3208 if ($changes{$id}) {
3209 my $changes = $changes{$id};
3210 ++$changes_found;
3211
3212 for my $field (keys %$changes) {
3213 $image->{$field} = $changes->{$field};
b95fc3a0 3214 }
ca9aa2bf
TC
3215 $image->save;
3216 }
a0a8147b 3217
e63c3728
TC
3218 my $old_storage = $image->{storage};
3219 my $new_storage = $auto_store ? '' : $cgi->param("storage$id");
3220 defined $new_storage or $new_storage = $image->{storage};
3221 $new_storage = $mgr->select_store($image->{image}, $new_storage, $image);
3222 if ($new_storage ne $old_storage) {
3223 eval {
3224 $image->{src} = $mgr->store($image->{image}, $new_storage, $image);
3225 $image->{storage} = $new_storage;
3226 $image->save;
3227 };
3228
3229 if ($old_storage ne 'local') {
3230 $mgr->unstore($image->{image}, $old_storage);
3231 }
3232 }
3233 }
3234
3235 # delete any image files that were replaced
3236 for my $old_image (values %old_images) {
3237 my ($image, $storage) = @$old_image{qw/image storage/};
3238 if ($storage ne 'local') {
3239 $mgr->unstore($image->{image}, $storage);
3240 }
3241 unlink "$image_dir/$image";
3242 }
3243
3244 if ($changes_found) {
b95fc3a0
TC
3245 generate_article($articles, $article) if $Constants::AUTO_GENERATE;
3246 }
e63c3728
TC
3247
3248 return $self->refresh($article, $cgi);
ca9aa2bf
TC
3249}
3250
58baa27b
TC
3251=item _service_error
3252
3253This function is called on various errors.
3254
3255If a _service parameter was supplied, returns text like:
3256
3257=over
3258
3259Result: failure
3260
3261Field-Error: I<field-name1> - I<message1>
3262
3263Field-Error: I<field-name2> - I<message2>
3264
3265=back
3266
3267If the request is detected as an ajax request or a _ parameter is
3268supplied, return JSON like:
3269
3270 { error: I<message> }
3271
3272Otherwise display the normal edit page with the error.
3273
3274=cut
3275
dbcd12e5 3276sub _service_error {
4d9eccec 3277 my ($self, $req, $article, $articles, $msg, $error, $code, $method) = @_;
dbcd12e5 3278
f3fc60c0
TC
3279 unless ($article) {
3280 my $mymsg;
3281 $article = $self->_dummy_article($req, $articles, \$mymsg);
3282 $article ||=
3283 {
e0ed81d7 3284 map $_ => '', BSE::TB::Article->columns
f3fc60c0
TC
3285 };
3286 }
3287
dbcd12e5
TC
3288 if ($req->cgi->param('_service')) {
3289 my $body = '';
3290 $body .= "Result: failure\n";
3291 if (ref $error) {
3292 for my $field (keys %$error) {
3293 my $text = $error->{$field};
3294 $text =~ tr/\n/ /;
3295 $body .= "Field-Error: $field - $text\n";
3296 }
3297 my $text = join ('/', values %$error);
3298 $text =~ tr/\n/ /;
3299 $body .= "Error: $text\n";
3300 }
58baa27b
TC
3301 elsif ($msg) {
3302 $body .= "Error: $msg\n";
3303 }
dbcd12e5
TC
3304 else {
3305 $body .= "Error: $error\n";
3306 }
3307 return
3308 {
3309 type => 'text/plain',
3310 content => $body,
3311 };
3312 }
58baa27b 3313 elsif ((() = $req->cgi->param('_')) ||
ca6c0ac9 3314 (exists $ENV{HTTP_X_REQUESTED_WITH}
58baa27b 3315 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/)) {
9b3a5df0 3316 $error ||= {};
60c9e2b7
TC
3317 my $result =
3318 {
3319 errors => $error,
3320 success => 0,
3321 };
9b3a5df0 3322 $msg and $result->{message} = $msg;
60bc6601 3323 $code and $result->{error_code} = $code;
ca6c0ac9
TC
3324 my $json_result = $req->json_content($result);
3325
3326 if (!exists $ENV{HTTP_X_REQUESTED_WITH}
3f9c8a96 3327 || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
ca6c0ac9
TC
3328 $json_result->{type} = "text/plain";
3329 }
3330
3331 return $json_result;
58baa27b 3332 }
dbcd12e5 3333 else {
4d9eccec
TC
3334 $method ||= "edit_form";
3335 return $self->$method($req, $article, $articles, $msg, $error);
dbcd12e5
TC
3336 }
3337}
3338
3339sub _service_success {
3340 my ($self, $results) = @_;
3341
3342 my $body = "Result: success\n";
3343 for my $field (keys %$results) {
3344 $body .= "$field: $results->{$field}\n";
3345 }
3346 return
3347 {
3348 type => 'text/plain',
3349 content => $body,
3350 };
3351}
3352
bd903bc5 3353# FIXME: eliminate this method and call get_ftype directly
5d1b1cbb
TC
3354sub _image_ftype {
3355 my ($self, $type) = @_;
3356
bd903bc5
TC
3357 require BSE::TB::Images;
3358 return BSE::TB::Images->get_ftype($type);
5d1b1cbb
TC
3359}
3360
ec9b99b2
TC
3361my %valid_exts =
3362 (
3363 tiff => "tiff,tif",
3364 jpg => "jpeg,jpg",
3365 pnm => "pbm,pgm,ppm",
3366 );
3367
3368sub _validate_image {
3369 my ($self, $filename, $fh, $rbasename, $error) = @_;
3370
3371 if ($fh) {
3372 if (-z $fh) {
3373 $$error = 'Image file is empty';
3374 return;
3375 }
3376 }
3377 else {
3378 $$error = 'Please enter an image filename';
3379 return;
3380 }
3381 my $imagename = $filename;
3382 $imagename .= ''; # force it into a string
43c194df 3383 (my $basename = $imagename) =~ tr/A-Za-z0-9_./-/cs;
ec9b99b2 3384
ea0b8f8e 3385 require BSE::ImageSize;
ec9b99b2 3386
ea0b8f8e 3387 my ($width,$height, $type) = BSE::ImageSize::imgsize($fh);
ec9b99b2
TC
3388
3389 unless (defined $width) {
3390 $$error = "Unknown image file type";
3391 return;
3392 }
3393
3394 my $lctype = lc $type;
3395 my @valid_exts = split /,/,
3396 BSE::Cfg->single->entry("valid image extensions", $lctype,
3397 $valid_exts{$lctype} || $lctype);
3398
3399 my ($ext) = $basename =~ /\.(\w+)\z/;
3400 if (!$ext || !grep $_ eq lc $ext, @valid_exts) {
3401 $basename .= ".$valid_exts[0]";
3402 }
3403 $$rbasename = $basename;
3404
3405 return ($width, $height, $type);
3406}
3407
aa2caf81
TC
3408my $last_display_order = 0;
3409
bf87e97c
TC
3410sub do_add_image {
3411 my ($self, $cfg, $article, $image, %opts) = @_;
ca9aa2bf 3412
bf87e97c
TC
3413 my $errors = $opts{errors}
3414 or die "No errors parameter";
ca9aa2bf 3415
bf87e97c 3416 my $imageref = $opts{name};
d794b180 3417 if (defined $imageref && $imageref ne '') {
4772671f
TC
3418 if ($imageref =~ /^[a-z_]\w+$/i) {
3419 # make sure it's unique
daee3409 3420 my @images = $self->get_images($article);
4772671f
TC
3421 for my $img (@images) {
3422 if (defined $img->{name} && lc $img->{name} eq lc $imageref) {
bf87e97c 3423 $errors->{name} = 'Image name must be unique to the article';
4772671f
TC
3424 last;
3425 }
3426 }
3427 }
3428 else {
bf87e97c 3429 $errors->{name} = 'Image name must be empty or alphanumeric beginning with an alpha character';
4772671f
TC