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