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