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