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