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