334f05838bd0e5c12519a5f0ebbcb5952fdebdb4
[bse.git] / site / cgi-bin / modules / BSE / Generate.pm
1 package BSE::Generate;
2 use strict;
3 use BSE::TB::Articles;
4 use Constants qw($LOCAL_FORMAT $BODY_EMBED 
5                  $EMBED_MAX_DEPTH $HAVE_HTML_PARSER);
6 use DevHelp::Tags;
7 use BSE::Util::HTML;
8 use BSE::Util::Tags qw(tag_article);
9 use BSE::CfgInfo qw(custom_class cfg_image_dir cfg_image_uri);
10 use BSE::Util::Iterate;
11 use BSE::TB::Site;
12 use BSE::Variables;
13 use Scalar::Util ();
14 use base 'BSE::ThumbLow';
15 use base 'BSE::TagFormats';
16
17 =head1 NAME
18
19 Generate - provides base Squirel::Template actions for use in generating
20 pages.
21
22 =head1 SYNOPSIS
23
24 =head1 DESCRIPTION
25
26 This is probably better documented in L<templates.pod>.
27
28 =head1 VARIABLES
29
30 Template variables:
31
32 =over
33
34 =item *
35
36 url(article)
37
38 =item *
39
40 url(article, 1)
41
42 Return a URL for the given article, depending on admin_links mode.  If
43 the page is being generated with absolute URLs or a second true
44 parameter is supplied, the URL is convrted to an absolute URL if
45 necessary.
46
47 =item *
48
49 articles - the articles class.
50
51 =item *
52
53 generator - the generator object itself.
54
55 =back
56
57 =head1 COMMON TAGS
58
59 These tags can be used anywhere, including in admin templates.  It's
60 possible some admin code has been missed, if you find a place where
61 these cannot be used let us know.
62
63 =over
64
65 =item kb I<data tag>
66
67 Formats the give value in kI<whatevers>.  If you have a number that
68 could go over 1000 and you want it to use the 'k' metric prefix when
69 it does, use this tag.  eg. <:kb file sizeInBytes:>
70
71 =item date I<data tag>
72
73 =item date "I<format>" I<data tag>
74
75 Formats a date or date/time value from the database into something
76 more human readable.  If you don't supply a format then the default
77 format of "%d-%b-%Y" is used ("20-Mar-2002").
78
79 The I<format> is a strftime() format specification, if that means
80 anything to you.  If it doesn't, each code starts with % and are
81 replaced as follows:
82
83 =over
84
85 =item %a
86
87 abbreviated weekday name
88
89 =item %A
90
91 full weekday name
92
93 =item %b
94
95 abbreviated month name
96
97 =item %B
98
99 full month name
100
101 =item %c
102
103 "preferred" date and time representation
104
105 =item %d
106
107 day of the month as a 2 digit number
108
109 =item %H
110
111 hour (24-hour clock)
112
113 =item %I
114
115 hour (12-hour clock)
116
117 =item %j
118
119 day of year as a 3-digit number
120
121 =item %m
122
123 month as a 2 digit number
124
125 =item %M
126
127 minute as a 2 digit number
128
129 =item %p
130
131 AM or PM or their equivalents
132
133 =item %S
134
135 seconds as a 2 digit number
136
137 =item %U
138
139 week number as a 2 digit number (first Sunday as the first day of week 1)
140
141 =item %w
142
143 weekday as a decimal number (0-6)
144
145 =item %W
146
147 week number as a 2 digit number (first Monday as the first day of week 1)
148
149 =item %x
150
151 the locale's appropriate date representation
152
153 =item %X
154
155 the locale's appropriate time representation
156
157 =item %y
158
159 2-digit year without century
160
161 =item %Y
162
163 the full year
164
165 =item %Z
166
167 time zone name or abbreviation
168
169 =item %%
170
171 just '%'
172
173 =back
174
175 Your local strftime() implementation may implement some extensions to
176 the above, if your server is on a Unix system try running "man
177 strftime" for more information.
178
179 =item bodytext I<data tag>
180
181 Formats the text from the given tag in the same way that body text is.
182
183 =item ifEq I<data1> I<data2>
184
185 Checks if the 2 values are exactly equal.  This is a string
186 comparison.
187
188 The 2 data parameters can either be a tag reference in [], a literal
189 string inside "" or a single word.
190
191 =item ifMatch I<data1> I<data2>
192
193 Treats I<data2> as a perl regular expression and attempts to match
194 I<data1> against it.
195
196 The 2 data parameters can either be a tag reference in [], a literal
197 string inside "" or a single word.
198
199 =item cfg I<section> I<key>
200
201 =item cfg I<section> I<key> I<default>
202
203 Retrieves a value from the BSE configuration file.
204
205 If you don't supply a default then a default will be the empty string.
206
207 =item release
208
209 The release number of BSE.
210
211 =back
212
213 =head1 TAGS
214
215 =over 4
216
217 =item ifAdmin
218
219 Conditional tag, true if generating in admin mode.
220
221 =item iterator ... level1
222
223 Iterates over the listed level 1 articles.
224
225 =item level1 I<name>
226
227 The value of the I<name> field of the current level 1 article.
228
229 =item iterator ... level2
230
231 Iterates over the listed level 2 children of the current level 1 article.
232
233 =item level2 I<name>
234
235 The value of the I<name> field of the current level 2 article.
236
237 =item ifLevel2 I<name>
238
239 Conditional tag, true if the current level 1 article has any listed
240 level 2 children.
241
242 =item iterator ... level3
243
244 Iterates over the listed level 3 children of the current level 2 article.
245
246 =item level3 I<name>
247
248 The value of the I<name> field of the current level 3 article.
249
250 =item ifLevel3 I<name>
251
252 Conditional tag, true if the current level 2 article has any listed
253 level 3 children.
254
255 =item url I<which>
256
257 Returns a link to the specified article .  Due to the way the action
258 list is built, this can be article types defined in derived classes of
259 Generate, like the C<parent> article in BSE::Generate::Article.
260
261 =item money I<data tag>
262
263 Formats the given value as a monetary value.  This does not include a
264 currency symbol.  Internally BSE stores monetary values as integers to
265 prevent the loss of accuracy inherent in floating point numbers.  You
266 need to use this tag to display any monetary value.
267
268 =item ifInMenu I<which>
269
270 Conditional tag, true if the given item can appear in a menu.
271
272 =item titleImage I<imagename> I<text>
273
274 Generates an IMG tag if the given I<imagename> is in the title image
275 directory (F<titles> in the managed images directory).  If it doesn't
276 exist, produce I<text>.
277
278 =item embed I<which>
279
280 =item embed I<which> I<template>
281
282 =item embed I<which> I<template> I<maxdepth>
283
284 =item embed child
285
286 Embeds the article specified by which using either the specified
287 template or the articles template.
288
289 In this case I<which> can also be an article ID.
290
291 I<template> is a filename relative to the templates directory.  If
292 this is "-" then the articles template is used (so you can set
293 I<maxdepth> without setting the template.)  If I<template> contains a
294 C<$> sign it will be replaced with the name of the original template.
295
296 If I<maxdepth> is supplied and is less than the current maximum depth
297 then it becomes the new maximum depth.  This can be used with ifCanEmbed.
298
299 =item embed start ... embed end
300
301 Marks the range of text that would be embedded in a parent that used
302 C<embed child>.
303
304 =item ifEmbedded
305
306 Conditional tag, true if the current article is being embedded.
307
308 =back
309
310 =head1 C<generator> METHODS
311
312 =over
313
314 =cut
315
316 our $VERSION = "1.024";
317
318 my $excerptSize = 300;
319
320 sub new {
321   my ($class, %opts) = @_;
322   unless ($opts{cfg}) {
323     require Carp;
324     Carp->import('confess');
325     confess("cfg missing on generator->new call");
326   }
327   $opts{maxdepth} = $EMBED_MAX_DEPTH unless exists $opts{maxdepth};
328   $opts{depth} = 0 unless $opts{depth};
329   $opts{vars} =
330     {
331      cfg => $opts{cfg},
332      bse => BSE::Variables->variables(%opts),
333     };
334   $opts{varstack} = [];
335   my $self = bless \%opts, $class;
336   $self->set_variable_class(articles => "BSE::TB::Articles");
337   $opts{vars}{generator} = $self;
338   Scalar::Util::weaken($opts{vars}{generator});
339
340   return $self;
341 }
342
343 sub cfg {
344   $_[0]{cfg};
345 }
346
347 sub request {
348   $_[0]{request};
349 }
350
351 sub url {
352   my ($self, $article, $force_abs) = @_;
353
354   my $url = $self->{admin_links} ? $article->admin : $article->link;
355   if (!$self->{admin} && $self->{admin_links}) {
356     $url .= $url =~ /\?/ ? "&" : "?";
357     $url .= "admin=0&admin_links=1";
358   }
359
360   if (($force_abs || $self->abs_urls($article)) && $url !~ /^\w+:/) {
361     $url = $self->cfg->entryErr("site", "url") . $url;
362   }
363
364   return $url;
365 }
366
367 sub site {
368   my $self = shift;
369   $self->{site} ||= BSE::TB::Site->new;
370   return $self->{site};
371 }
372
373 sub set_variable {
374   my ($self, $name, $value) = @_;
375
376   $self->{vars}{$name} = $value;
377
378   return 1;
379 }
380
381 sub set_variable_class {
382   my ($self, $name, $class) = @_;
383
384   require Squirrel::Template;
385   $self->set_variable($name => Squirrel::Template::Expr::WrapClass->new($class));
386 }
387
388 sub variables {
389   my ($self) = @_;
390
391   return $self->{vars};
392 }
393
394 # replace commonly used characters
395 # like MS dumb-quotes
396 # unfortunately some browsers^W^Wnetscape don't support the entities yet <sigh>
397 sub make_entities {
398   my $text = shift;
399
400   $text =~ s/\226/-/g; # "--" looks ugly
401   $text =~ s/\222/'/g;
402   $text =~ s/\221/`/g;
403   $text =~ s/\&#8217;/'/g;
404
405   return $text;
406 }
407
408 sub summarize {
409   my ($self, $articles, $text, $acts, $length) = @_;
410
411   # remove any block level formatting
412   $self->remove_block($articles, $acts, \$text);
413
414   $text =~ tr/\n\r / /s;
415
416   if (length $text > $length) {
417     $text = substr($text, 0, $length);
418     $text =~ s/\s+\S+$//;
419
420     # roughly balance [ and ]
421     my $temp = $text;
422     1 while $temp =~ s/\s\[[^\]]*\]//; # eliminate matched
423     my $count = 0;
424     ++$count while $temp =~ s/\w\[[^\]]*$//; # count unmatched
425
426     $text .= ']' x $count;
427     $text .= '...';
428   }
429
430   # the formatter now adds <p></p> around the text, but we don't
431   # want that here
432   my $result = $self->format_body(articles => $articles, 
433                                   text => $text);
434   $result =~ s!<p>|</p>!!g;
435
436   return $result;
437 }
438
439 sub summary {
440   my ($self, $article, $limit) = @_;
441
442   $limit ||= $article->summaryLength;
443
444   return $self->summarize("BSE::TB::Articles", $article->body, $self->{acts}, $limit);
445 }
446
447 # attempts to move the given position forward if it's within a HTML tag,
448 # entity or just a word
449 sub adjust_for_html {
450   my ($self, $text, $pos) = @_;
451
452   # advance if in a tag
453   return $pos + length $1 
454     if substr($text, 0, $pos) =~ /<[^<>]*$/
455       && substr($text, $pos) =~ /^([^<>]*>)/;
456   return $pos + length $1
457     if substr($text, 0, $pos) =~ /&[^;&]*$/
458       && substr($text, $pos) =~ /^([^;&]*;)/;
459   return $pos + length $1
460     if $pos <= length $text
461       && substr($text, $pos-1, 1) =~ /\w$/
462       && substr($text, $pos) =~ /^(\w+)/;
463
464   return $pos;
465 }
466
467 # raw html - this has some limitations
468 # the input text has already been escaped, so we need to unescape it
469 # too bad if you want [] in your html (but you can use entities)
470 sub _make_html {
471   return unescape_html($_[0]);
472 }
473
474 sub _embed_low {
475   my ($self, $acts, $articles, $what, $template, $maxdepth, $templater) = @_;
476
477   $maxdepth = $self->{maxdepth} 
478     if !$maxdepth || $maxdepth > $self->{maxdepth};
479   #if ($self->{depth}) {
480   #  print STDERR "Embed depth $self->{depth}\n";
481   #}
482   if ($self->{depth} > $self->{maxdepth}) {
483     if ($self->{maxdepth} == $EMBED_MAX_DEPTH) {
484       return "** too many embedding levels **";
485     }
486     else {
487       return '';
488     }
489   }
490
491   my $embed;
492   if ($what =~ /^alias:([a-z]\w*)$/) {
493     my $alias = $1;
494     ($embed) = $articles->getBy(linkAlias => $alias)
495       or return "** Cannot find article aliased $alias to be embedded **";;
496   }
497   else {
498     my $id;
499     if ($what !~ /^\d+$/) {
500       # not an article id, assume there's an article here we can use
501       $id = $acts->{$what} && $templater->perform($acts, $what, 'id');
502       unless ($id && $id =~ /^\d+$/) {
503         # save it for later
504         defined $template or $template = "-";
505         return "<:embed $what $template $maxdepth:>";
506       }
507     }
508     else {
509       $id = $what;
510     }
511
512     $embed = $articles->getByPkey($id)
513       or return "** Cannot find article $id to be embedded **";;
514   }
515
516   my $gen = $self;
517   if (ref($self) ne $embed->{generator}) {
518     my $genname = $embed->{generator};
519     $genname =~ s#::#/#g; # broken on MacOS I suppose
520     $genname .= ".pm";
521     eval {
522       require $genname;
523     };
524     if ($@) {
525       print STDERR "Cannot load generator $embed->{generator}: $@\n";
526       return "** Cannot load generator $embed->{generator} for article $embed->{id} **";
527     }
528     my $top = $self->{top} || $embed;
529     $gen = $embed->{generator}->new
530       (
531        admin=>$self->{admin},
532        admin_links => $self->{admin_links},
533        cfg=>$self->{cfg},
534        request=>$self->{request},
535        top=>$top
536       );
537   }
538
539   my $olddepth = $gen->{depth};
540   $gen->{depth} = $self->{depth}+1;
541   my $oldmaxdepth = $gen->{maxdepth};
542   $gen->{maxdepth} = $maxdepth;
543   $template = "" if defined($template) && $template eq "-";
544   my $result = $gen->embed($embed, $articles, $template);
545   $gen->{depth} = $olddepth;
546   $gen->{maxdepth} = $oldmaxdepth;
547
548   return $result;
549 }
550
551 sub _body_embed {
552   my ($self, $acts, $articles, $which, $template, $maxdepth) = @_;
553
554   my $text = $self->_embed_low($acts, $articles, $which, $template, $maxdepth);
555
556   return $text;
557 }
558
559 sub formatter_class {
560   require BSE::Formatter::Article;
561   return 'BSE::Formatter::Article'
562 }
563
564 # replace markup, insert img tags
565 sub format_body {
566   my $self = shift;
567   my (%opts) =
568     (
569      abs_urls => 0, 
570      imagepos => 'tr', 
571      auto_images => 1,
572      images => [], 
573      files => [],
574      acts => {}, 
575      @_
576     );
577
578   my $acts = $opts{acts};
579   my $articles = $opts{articles};
580   my $body = $opts{text};
581   my $imagePos = $opts{imagepos};
582   my $abs_urls = $opts{abs_urls};
583   my $auto_images = $opts{auto_images};
584   my $templater = $opts{templater};
585   my $images = $opts{images};
586   my $files = $opts{files};
587
588   return substr($body, 6) if $body =~ /^<html>/i;
589
590   my $formatter_class = $self->formatter_class;
591
592   my $formatter = $formatter_class->new(gen => $self, 
593                                         acts => $acts, 
594                                         articles => $articles,
595                                         abs_urls => $abs_urls, 
596                                         auto_images => \$auto_images,
597                                         images => $images, 
598                                         files => $files,
599                                         templater => $templater);
600
601   $body = $formatter->format($body);
602
603   my $xhtml = $self->{cfg}->entry('basic', 'xhtml', 1);
604
605   # we don't format named images
606   my @images = grep $_->{name} eq '', @$images;
607   if ($auto_images
608       && @images
609       && $self->{cfg}->entry('basic', 'auto_images', 1)
610       && $imagePos ne 'xx') {
611     # the first image simply goes where we're told to put it
612     # the imagePos is [tb][rl] (top|bottom)(right|left)
613     my $align = $imagePos =~ /r/ ? 'right' : 'left';
614
615     # Offset the end a bit so we don't get an image hanging as obviously
616     # off the end.
617     # Numbers determined by trial - it can still look pretty rough.
618     my $len = length $body;
619     if ($len > 1000) {
620       $len -= 500; 
621     }
622     elsif ($len > 800) {
623       $len -= 200;
624     }
625
626     #my $incr = @images > 1 ? 2*$len / (2*@images+1) : 0;
627     my $incr = $len / @images;
628     # inserting the image tags moves character positions around
629     # so we need the temp buffer
630     if ($imagePos =~ /b/) {
631       @images = reverse @images;
632       if (@images % 2 == 0) {
633         # starting at the bottom, swap it around
634         $align = $align eq 'right' ? 'left' : 'right';
635       }
636     }
637     my $output = '';
638     for my $image (@images) {
639       # adjust to make sure this isn't in the middle of a tag or entity
640       my $pos = $self->adjust_for_html($body, $incr);
641       
642       my $img = $image->inline(cfg => $self->{cfg}, align => $align);
643       $output .= $img;
644       $output .= substr($body, 0, $pos);
645       substr($body, 0, $pos) = '';
646       $align = $align eq 'right' ? 'left' : 'right';
647     }
648     $body = $output . $body; # don't forget the rest of it
649   }
650   
651   return make_entities($body);
652 }
653
654 sub embed {
655   my ($self, $article, $articles, $template) = @_;
656
657   if (defined $template && $template =~ /\$/) {
658     $template =~ s/\$/$article->{template}/;
659   }
660   else {
661     $template = $article->{template}
662       unless defined($template) && $template =~ /\S/;
663   }
664
665   my $html = BSE::Template->get_source($template, $self->{cfg});
666
667   # the template will hopefully contain <:embed start:> and <:embed end:>
668   # tags
669   # otherwise pull out the body content
670   if ($html =~ /<:\s*embed\s*start\s*:>(.*)<:\s*embed\s*end\s*:>/s
671      || $html =~ m"<\s*body[^>]*>(.*)<\s*/\s*body>"s) {
672     $html = $1;
673   }
674   return $self->generate_low($html, $article, $articles, 1);
675 }
676
677 =item vembed(article)
678
679 =item vembed(article, template)
680
681 Embed the specified article using either the article template or the
682 specified template.
683
684 =back
685
686 =head1 GENERATOR TAGS
687
688 =over
689
690 =cut
691
692
693 sub vembed {
694   my ($self, $article, $template) = @_;
695
696   return $self->embed($article, "BSE::TB::Articles", $template);
697 }
698
699 sub iter_kids_of {
700   my ($self, $state, $args, $acts, $name, $templater) = @_;
701
702   my $filter = $self->_get_filter(\$args);
703
704   $state->{parentid} = undef;
705   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
706   for my $id (@ids) {
707     unless ($id =~ /^\d+$|^-1$/) {
708       $id = $templater->perform($acts, $id, "id");
709     }
710   }
711   @ids = grep /^\d+$|^-1$/, @ids;
712   if (@ids == 1) {
713     $state->{parentid} = $ids[0];
714   }
715   $self->_do_filter($filter, map BSE::TB::Articles->listedChildren($_), @ids);
716 }
717
718 my $cols_re; # cache for below
719
720 {
721   my %expr_cache;
722
723   sub _get_filter {
724     my ($self, $rargs) = @_;
725     
726     if ($$rargs =~ s/filter:\s+(.*)\z//s) {
727       my $expr = $1;
728       my $orig_expr = $expr;
729       unless ($cols_re) {
730         my $cols_expr = '(' . join('|', BSE::TB::Article->columns) . ')';
731         $cols_re = qr/\[$cols_expr\]/;
732       }
733       $expr =~ s/$cols_re/\$article->{$1}/g;
734       $expr =~ s/ARTICLE/\$article/g;
735       #print STDERR "Expr $expr\n";
736       my $filter = $expr_cache{$expr};
737       unless ($filter) {
738         $filter = eval 'sub { my $article = shift; '.$expr.'; }';
739         if ($@) {
740           print STDERR "** Failed to compile filter expression >>$expr<< built from >>$orig_expr<<\n";
741           return;
742         }
743         $expr_cache{$expr} = $filter;
744       }
745       
746       return $filter;
747     }
748     else {
749       return;
750     }
751   }
752 }
753
754 sub _do_filter {
755   my ($self, $filter, @articles) = @_;
756
757   $filter
758     or return @articles;
759
760   return grep $filter->($_), @articles;
761 }
762
763 sub iter_all_kids_of {
764   my ($self, $state, $args, $acts, $name, $templater) = @_;
765
766   my $filter = $self->_get_filter(\$args);
767
768   $state->{parentid} = undef;
769   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
770   for my $id (@ids) {
771     unless ($id =~ /^\d+$|^-1$/) {
772       $id = $templater->perform($acts, $id, "id");
773     }
774   }
775   @ids = grep /^\d+$|^-1$/, @ids;
776   @ids == 1 and $state->{parentid} = $ids[0];
777     
778   $self->_do_filter($filter, map BSE::TB::Articles->all_visible_kids($_), @ids);
779 }
780
781 sub iter_inlines {
782   my ($self, $state, $args, $acts, $name, $templater) = @_;
783
784   my $filter = $self->_get_filter(\$args);
785
786   $state->{parentid} = undef;
787   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
788   for my $id (@ids) {
789     unless ($id =~ /^\d+$/) {
790       $id = $templater->perform($acts, $id, "id");
791     }
792   }
793   @ids = grep /^\d+$/, @ids;
794   @ids == 1 and $state->{parentid} = $ids[0];
795
796   $self->_do_filter($filter, map BSE::TB::Articles->getByPkey($_), @ids);
797 }
798
799 sub iter_gimages {
800   my ($self, $args) = @_;
801
802   unless ($self->{gimages}) {
803     $self->_init_gimages;
804   }
805
806   if ($args =~ m!^named\s+/([^/]+)/$!) {
807     my $re = $1;
808     return grep $_->{name} =~ /$re/i, @{$self->{gimages_a}};
809   }
810   else {
811     return @{$self->{gimages_a}};
812   }
813 }
814
815 sub iter_gfiles {
816   my ($self, $args) = @_;
817
818   unless ($self->{gfiles}) {
819     my @gfiles = BSE::TB::Articles->global_files;
820     my %gfiles = map { $_->{name} => $_ } @gfiles;
821     $self->{gfiles} = \%gfiles;
822   }
823
824   my @gfiles = 
825     sort { $a->{name} cmp $b->{name} } values %{$self->{gfiles}};
826   if ($args =~ m!^named\s+/([^/]+)/$!) {
827     my $re = $1;
828     return grep $_->{name} =~ /$re/i, @gfiles;
829   }
830   elsif ($args =~ m(^filter: (.*)$)s) {
831     my $expr = $1;
832     $expr =~ s/FILE\[(\w+)\]/\$file->$1/g;
833     my $sub = eval 'sub { my $file = shift; ' . $expr . '; }';
834     $sub
835       or die "* Cannot compile sub from filter $expr: $@ *";
836     return grep $sub->($_), @gfiles;
837   }
838   else {
839     return @gfiles;
840   }
841 }
842
843 sub admin_tags {
844   my ($self) = @_;
845
846   $self->{admin} or return;
847
848   return BSE::Util::Tags->secure($self->{request});
849 }
850
851 sub _static_images {
852   my ($self) = @_;
853
854   my $static = $self->{cfg}->entry('basic', 'static_thumbnails', 1);
855   $self->{admin} and $static = 0;
856   $self->{dynamic} and $static = 0;
857
858   return $static;
859 }
860
861 # implements popimage and gpopimage
862 sub do_popimage_low {
863   my ($self, $im, $class) = @_;
864
865   return $im->popimage
866     (
867      cfg => $self->cfg,
868      class => $class,
869      static => $self->_static_images,
870     );
871
872 }
873
874 sub do_gpopimage {
875   my ($self, $image_id, $class) = @_;
876
877   my $im = $self->get_gimage($image_id)
878     or return "* Unknown global image '$image_id' *";
879
880   return $self->do_popimage_low($im, $class);
881 }
882
883 sub _sthumbimage_low {
884   my ($self, $geometry, $im, $field) = @_;
885
886   return $self->_thumbimage_low($geometry, $im, $field, $self->{cfg}, $self->_static_images);
887 }
888
889 sub tag_gthumbimage {
890   my ($self, $rcurrent, $args, $acts, $name, $templater) = @_;
891
892   my ($geometry_id, $id, $field) = DevHelp::Tags->get_parms($args, $acts, $templater);
893
894   return $self->do_gthumbimage($geometry_id, $id, $field, $$rcurrent);
895 }
896
897 sub _find_image {
898   my ($self, $acts, $templater, $article_id, $image_tags, $msg) = @_;
899
900   my $article;
901   if ($article_id =~ /^\d+$/) {
902     require BSE::TB::Articles;
903     $article = BSE::TB::Articles->getByPkey($article_id);
904     unless ($article) {
905       $$msg = "* no article $article_id found *";
906       return;
907     }
908   }
909   elsif ($acts->{$article_id}) {
910     my $id = $templater->perform($acts, $article_id, "id");
911     $article = BSE::TB::Articles->getByPkey($id);
912     unless ($article) {
913       $$msg = "* article $article_id/$id not found *";
914       return;
915     }
916   }
917   else {
918     ($article) = BSE::TB::Articles->getBy(linkAlias => $article_id);
919     unless ($article) {
920       $$msg = "* no article $article_id found *";
921       return;
922     }
923   }
924   $article
925     or return;
926
927   my @images = $article->images;
928   my $im;
929   for my $tag (split /,/, $image_tags) {
930     if ($tag =~ m!^/(.*)/$!) {
931       my $re = $1;
932       ($im) = grep $_->{name} =~ /$re/i, @images
933         and last;
934     }
935     elsif ($tag =~ /^\d+$/) {
936       if ($tag >= 1 && $tag <= @images) {
937         $im = $images[$tag-1];
938         last;
939       }
940     }
941     elsif ($tag =~ /^[^\W\d]\w*$/) {
942       ($im) = grep $_->{name} eq $tag, @images
943         and last;
944     }
945   }
946   unless ($im) {
947     $$msg = "* no image matching $image_tags found *";
948     return;
949   }
950
951   return $im;
952 }
953
954 sub tag_sthumbimage {
955   my ($self, $args, $acts, $name, $templater) = @_;
956
957   my ($article_id, $geometry, $image_tags, $field) = split ' ', $args;
958
959   my $msg;
960   my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
961     or return $msg;
962   
963   return $self->_sthumbimage_low($geometry, $im, $field);
964 }
965
966 sub tag_simage {
967   my ($self, $args, $acts, $name, $templater) = @_;
968
969   my ($article_id, $image_tags, $field, $rest) = split ' ', $args, 4;
970
971   my $msg;
972   my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
973     or return $msg;
974
975   return $self->_format_image($im, $field, $rest);
976 }
977
978 =item iterator vimages I<articles> I<filter>
979
980 =item iterator vimages I<articles>
981
982 Iterates over the images belonging to the articles specified.
983
984 I<articles> can be any of:
985
986 =over
987
988 =item *
989
990 article - the current article
991
992 =item *
993
994 children - all visible children (including stepkids) of the current
995 article
996
997 =item *
998
999 parent - the parent of the current article
1000
1001 =item *
1002
1003 I<number> - a numeric article id, such as C<10>.
1004
1005 =item *
1006
1007 alias(I<alias>) - a link alias of an article
1008
1009 =item *
1010
1011 childrenof(I<articles>) - an articles that are children of
1012 I<articles>.  I<articles> can be any normal article spec, so
1013 C<childrenof(childrenof(-1))> is valid.
1014
1015 =item *
1016
1017 I<tagname> - a tag name referring to an article.
1018
1019 =back
1020
1021 I<articles> has [] replacement done before parsing.
1022
1023 I<filter> can be missing, or either of:
1024
1025 =over
1026
1027 =item *
1028
1029 named /I<regexp>/ - images with names matching the given regular
1030 expression
1031
1032 =item *
1033
1034 numbered I<number> - images with the given index.
1035
1036 =back
1037
1038 Items for this iterator are vimage and vthumbimage.
1039
1040 =cut
1041
1042 sub iter_vimages {
1043   my ($self, $article, $args, $acts, $name, $templater) = @_;
1044
1045   my $re;
1046   my $num;
1047   if ($args =~ s!\s+named\s+/([^/]+)/$!!) {
1048     $re = $1;
1049   }
1050   elsif ($args =~ s!\s+numbered\s+(\d+)$!!) {
1051     $num = $1;
1052   }
1053   my @args = DevHelp::Tags->get_parms($args, $acts, $templater);
1054   my @images;
1055   for my $article_id (map { split /[, ]/ } @args) {
1056     my @articles = $self->_find_articles($article_id, $article, $acts, $name, $templater);
1057     for my $article (@articles) {
1058       my @aimages = $article->images;
1059       if (defined $re) {
1060         push @images, grep $_->{name} =~ /$re/, @aimages;
1061       }
1062       elsif (defined $num) {
1063         if ($num >= 0 && $num <= @aimages) {
1064           push @images, $aimages[$num-1];
1065         }
1066       }
1067       else {
1068         push @images, @aimages;
1069       }
1070     }
1071   }
1072
1073   return @images;
1074 }
1075
1076 =item vimage field
1077
1078 =item vimage
1079
1080 Retrieve the given field from the current vimage, or display the image.
1081
1082 =cut
1083
1084 sub tag_vimage {
1085   my ($self, $rvimage, $args) = @_;
1086
1087   $$rvimage or return '** no current vimage **';
1088
1089   my ($field, $rest) = split ' ', $args, 2;
1090
1091   return $self->_format_image($$rvimage, $field, $rest);
1092 }
1093
1094 =item vthumbimage geometry field
1095
1096 =item vthumbimage geometry
1097
1098 Retrieve the given field from the thumbnail of the current vimage or
1099 display the thumbnail.
1100
1101 =cut
1102
1103 sub tag_vthumbimage {
1104   my ($self, $rvimage, $args) = @_;
1105
1106   $$rvimage or return '** no current vimage **';
1107   my ($geo, $field) = split ' ', $args;
1108
1109   return $self->_sthumbimage_low($geo, $$rvimage, $field);
1110 }
1111
1112 sub _find_articles {
1113   my ($self, $article_id, $article, $acts, $name, $templater) = @_;
1114
1115   if ($article_id =~ /^\d+$/) {
1116     my $result = BSE::TB::Articles->getByPkey($article_id);
1117     $result or print STDERR "** Unknown article id $article_id **\n";
1118     return $result ? $result : ();
1119   }
1120   elsif ($article_id =~ /^alias\((\w+)\)$/) {
1121     my $result = BSE::TB::Articles->getBy(linkAlias => $1);
1122     $result or print STDERR "** Unknown article alias $article_id **\n";
1123     return $result ? $result : ();
1124   }
1125   elsif ($article_id =~ /^childrenof\((.*)\)$/) {
1126     my $id = $1;
1127     if ($id eq '-1') {
1128       return BSE::TB::Articles->all_visible_kids(-1);
1129     }
1130     else {
1131       my @parents = $self->_find_articles($id, $article, $acts, $name, $templater)
1132         or return;
1133       return map $_->all_visible_kids, @parents;
1134     }
1135   }
1136   elsif ($acts->{$article_id}) {
1137     my $id = $templater->perform($acts, $article_id, 'id');
1138     if ($id && $id =~ /^\d+$/) {
1139       return BSE::TB::Articles->getByPkey($id);
1140     }
1141   }
1142   print STDERR "** Unknown article identifier $article_id **\n";
1143
1144   return;
1145 }
1146
1147 sub baseActs {
1148   my ($self, $articles, $acts, $article, $embedded) = @_;
1149
1150   # used to generate the side menu
1151   my $section_index = -1;
1152   my @sections = $articles->listedChildren(-1);
1153     #sort { $a->{displayOrder} <=> $b->{displayOrder} } 
1154     #grep $_->{listed}, $articles->sections;
1155   my $subsect_index = -1;
1156   my @subsections; # filled as we move through the sections
1157   my @level3; # filled as we move through the subsections
1158   my $level3_index = -1;
1159
1160   my $cfg = $self->{cfg} || BSE::Cfg->single;
1161   my %extras = $cfg->entriesCS('extra tags');
1162   for my $key (keys %extras) {
1163     # follow any links
1164     my $data = $cfg->entryVar('extra tags', $key);
1165     $extras{$key} = sub { $data };
1166   }
1167
1168   my $current_gimage;
1169   my $current_vimage;
1170   my $it = BSE::Util::Iterate->new;
1171   my $art_it = BSE::Util::Iterate::Article->new(cfg => $cfg,
1172                                                 admin => $self->{admin},
1173                                                 top => $self->{top});
1174   my $weak_self = $self;
1175   Scalar::Util::weaken($weak_self);
1176   $self->set_variable(url => sub { $weak_self->url(@_) });
1177   return 
1178     (
1179      %extras,
1180
1181      custom_class($cfg)->base_tags($articles, $acts, $article, $embedded, $cfg, $self),
1182      $self->admin_tags(),
1183      BSE::Util::Tags->static($acts, $self->{cfg}),
1184      # for embedding the content from children and other sources
1185      ifEmbedded=> sub { $embedded },
1186      embed => sub {
1187        my ($args, $acts, $name, $templater) = @_;
1188        return '' if $args eq 'start' || $args eq 'end';
1189        my ($what, $template, $maxdepth) = split ' ', $args;
1190        undef $maxdepth if defined $maxdepth && $maxdepth !~ /^\d+/;
1191        return $self->_embed_low($acts, $articles, $what, $template, $maxdepth, $templater);
1192      },
1193      ifCanEmbed=> sub { $self->{depth} <= $self->{maxdepth} },
1194
1195      summary =>
1196      sub {
1197        my ($args, $acts, $name, $templater) = @_;
1198        my ($which, $limit) = DevHelp::Tags->get_parms($args, $acts, $templater);
1199        $which or $which = "child";
1200        $limit or $limit = $article->{summaryLength};
1201        $acts->{$which}
1202          or return "<:summary $which Cannot find $which:>";
1203        my $id = $templater->perform($acts, $which, "id")
1204          or return "<:summary $which No id returned :>";
1205        my $article = $articles->getByPkey($id)
1206          or return "<:summary $which Cannot find article $id:>";
1207        return $self->summarize($articles, $article->{body}, $acts, $limit);
1208      },
1209      ifAdmin => sub { $self->{admin} },
1210      ifAdminLinks => sub { $self->{admin_links} },
1211      
1212      # for generating the side menu
1213      iterate_level1_reset => sub { $section_index = -1 },
1214      iterate_level1 => sub {
1215        ++$section_index;
1216        if ($section_index < @sections) {
1217          #@subsections = grep $_->{listed}, 
1218          #  $articles->children($sections[$section_index]->{id});
1219          @subsections = grep { $_->{listed} != 2 }
1220            $articles->listedChildren($sections[$section_index]->{id});
1221          $subsect_index = -1;
1222          return 1;
1223        }
1224        else {
1225          return 0;
1226        }
1227      },
1228      level1 => sub {
1229        return tag_article($sections[$section_index], $cfg, $_[0]);
1230      },
1231
1232      # used to generate a list of subsections for the side-menu
1233      iterate_level2 => sub {
1234        ++$subsect_index;
1235        if ($subsect_index < @subsections) {
1236          @level3 = grep { $_->{listed} != 2 }
1237            $articles->listedChildren($subsections[$subsect_index]{id});
1238          $level3_index = -1;
1239          return 1;
1240        }
1241        return 0;
1242      },
1243      level2 => sub {
1244        return tag_article($subsections[$subsect_index], $cfg, $_[0]);
1245      },
1246      ifLevel2 => 
1247      sub {
1248        return scalar @subsections;
1249      },
1250      
1251      # possibly level3 items
1252      iterate_level3 => sub {
1253        return ++$level3_index < @level3;
1254      },
1255      level3 => sub { 
1256        tag_article($level3[$level3_index], $cfg, $_[0])
1257      },
1258      ifLevel3 => sub { scalar @level3 },
1259
1260      # generate an admin or link url, depending on admin state
1261      url=>
1262      sub {
1263        my ($name, $acts, $func, $templater) = @_;
1264        my $item = $self->{admin_links} ? 'admin' : 'link';
1265        $acts->{$name}
1266          or die "ENOIMPL\n";
1267        my $url = $templater->perform($acts, $name, $item);
1268        if (!$self->{admin} && $self->{admin_links}) {
1269          $url .= $url =~ /\?/ ? "&" : "?";
1270          $url .= "admin=0&admin_links=1";
1271        }
1272        return $url;
1273      },
1274      ifInMenu =>
1275      sub {
1276        $acts->{$_[0]} or return 0;
1277        return $acts->{$_[0]}->('listed') == 1;
1278      },
1279      titleImage=>
1280      sub {
1281        my ($image, $text) = split ' ', $_[0];
1282
1283        my $image_dir = cfg_image_dir();
1284        if (-e "$image_dir/titles/$image") {
1285          my $image_uri = cfg_image_uri();
1286          return qq!<img src="$image_uri/titles/!.$image .qq!" border=0>!
1287        }
1288        else {
1289          return escape_html($text);
1290        }
1291      },
1292      $art_it->make( code => [ iter_kids_of => $self ],
1293                     single => 'ofchild',
1294                     plural => 'children_of', 
1295                     nocache => 1,
1296                     state => 1 ), 
1297      $art_it->make( code => [ iter_kids_of => $self ],
1298                     single => 'ofchild2',
1299                     plural => 'children_of2',
1300                     nocache => 1,
1301                     state => 1 ),
1302      $art_it->make( code => [ iter_kids_of => $self ],
1303                     single => 'ofchild3',
1304                     plural => 'children_of3',
1305                     nocache => 1,
1306                     state => 1 ),
1307      $art_it->make( code => [ iter_all_kids_of => $self ], 
1308                     single => 'ofallkid',
1309                     plural => 'allkids_of',
1310                     state => 1 ), 
1311      $art_it->make( code => [ iter_all_kids_of => $self ],
1312                     single => 'ofallkid2', 
1313                     plural => 'allkids_of2', 
1314                     nocache => 1,
1315                     state => 1 ), 
1316      $art_it->make( code => [ iter_all_kids_of => $self ],
1317                     single => 'ofallkid3',
1318                     plural => 'allkids_of3',
1319                     nocache => 1,
1320                     state => 1 ), 
1321      $art_it->make( code => [ iter_all_kids_of => $self ],
1322                     single => 'ofallkid4',
1323                     plural => 'allkids_of4',
1324                     nocache => 1,
1325                     state => 1 ), 
1326      $art_it->make( code => [ iter_all_kids_of => $self ],
1327                     single => 'ofallkid5',
1328                     plural => 'allkids_of5',
1329                     nocache => 1,
1330                     state => 1 ), 
1331      $art_it->make( code => [ iter_inlines => $self ],
1332                     single => 'inline',
1333                     plural => 'inlines',
1334                     nocache => 1,
1335                     state => 1 ), 
1336      gimage => 
1337      sub {
1338        my ($args, $acts, $func, $templater) = @_;
1339        my ($name, $align, @rest) = 
1340          DevHelp::Tags->get_parms($args, $acts, $templater);
1341        my $rest = "@rest";
1342
1343        my $im;
1344        defined $name && length $name
1345          or return '* missing or empty name parameter for gimage *';
1346        if ($name eq '-') {
1347          $im = $current_gimage
1348            or return '';
1349        }
1350        else {
1351          $im = $self->get_gimage($name)
1352            or return '';
1353        }
1354
1355        $self->_format_image($im, $align, $rest);
1356      },
1357      $it->make_iterator( [ \&iter_gimages, $self ], 'gimagei', 'gimages', 
1358                          undef, undef, undef, \$current_gimage),
1359      gfile => 
1360      sub {
1361        my ($name, $field) = split ' ', $_[0], 3;
1362
1363        my $file = $self->get_gfile($name)
1364          or return '';
1365
1366        $self->_format_file($file, $field);
1367      },
1368      $it->make_iterator( [ \&iter_gfiles, $self ], 'gfilei', 'gfiles'),
1369      gthumbimage => [ tag_gthumbimage => $self, \$current_gimage ],
1370      sthumbimage => [ tag_sthumbimage => $self ],
1371      simage => [ tag_simage => $self ],
1372      $it->make_iterator( [ iter_vimages => $self, $article ], 'vimage', 'vimages', undef, undef, undef, \$current_vimage),
1373      vimage => [ tag_vimage => $self, \$current_vimage ],
1374      vthumbimage => [ tag_vthumbimage => $self, \$current_vimage ],
1375     );
1376 }
1377
1378 sub _highlight_partial {
1379   my ($self) = @_;
1380
1381   $self->{cfg}->entryBool('search', 'highlight_partial', 1);
1382 }
1383
1384 sub find_terms {
1385   my ($self, $body, $case_sensitive, $terms) = @_;
1386
1387   my $eow = $self->_highlight_partial ? "" : qr/\b/;
1388   # locate the terms
1389   my @found;
1390   if ($case_sensitive) {
1391     for my $term (@$terms) {
1392       if ($$body =~ /^(.*?)\b\Q$term\E$eow/s) {
1393         push(@found, [ length($1), $term ]);
1394       }
1395     }
1396   }
1397   else {
1398     for my $term (@$terms) {
1399       if ($$body =~ /^(.*?)\b\Q$term\E$eow/is) {
1400         push(@found, [ length($1), $term ]);
1401       }
1402     }
1403   }
1404
1405   return @found;
1406 }
1407
1408 # this takes the same inputs as _make_table(), but eliminates any
1409 # markup instead
1410 sub _cleanup_table {
1411   my ($opts, $data) = @_;
1412   my @lines = split /\n/, $data;
1413   for (@lines) {
1414     s/^[^|]*\|//;
1415     tr/|/ /s;
1416   }
1417   return join(' ', @lines);
1418 }
1419
1420 # produce a nice excerpt for a found article
1421 sub excerpt {
1422   my ($self, $article, $found, $case_sensitive, $terms, $type, $body) = @_;
1423
1424   if (!$body) {
1425     $body = $article->{body};
1426     
1427     # we remove any formatting tags here, otherwise we get wierd table
1428     # rubbish or other formatting in the excerpt.
1429     my @files = $article->files;
1430     $self->remove_block('BSE::TB::Articles', [], \$body, \@files);
1431     1 while $body =~ s/[bi]\[([^\]\[]+)\]/$1/g;
1432   }
1433     
1434   $body = escape_html($body);
1435
1436   $type ||= 'body';
1437
1438   my @found = $self->find_terms(\$body, $case_sensitive, $terms);
1439
1440   my @reterms = @$terms;
1441   for (@reterms) {
1442     tr/ / /s;
1443     $_ = quotemeta;
1444     s/\\?\s+/\\s+/g;
1445   }
1446   # do a reverse sort so that the longer terms (and composite
1447   # terms) are replaced first
1448   my $re_str = join("|", reverse sort @reterms);
1449   my $re;
1450   my $cfg = $self->{cfg};
1451   if ($self->_highlight_partial) {
1452     $re = $case_sensitive ? qr/\b($re_str)/ : qr/\b($re_str)/i;
1453   }
1454   else {
1455     $re = $case_sensitive ? qr/\b($re_str)\b/ : qr/\b($re_str)\b/i;
1456   }
1457
1458   # this used to try searching children as well, but it broke more
1459   # than it fixed
1460   if (!@found) {
1461     # we tried hard and failed
1462     # return a generic article
1463     if (length $body > $excerptSize) {
1464       $body = substr($body, 0, $excerptSize);
1465       $body =~ s/\S+\s*$/.../;
1466     }
1467     $$found = 0;
1468     return $body;
1469   }
1470
1471   # only the first 5
1472   splice(@found, 5,-1) if @found > 5;
1473   my $itemSize = $excerptSize / @found;
1474
1475   # try to combine any that are close
1476   @found = sort { $a->[0] <=> $b->[0] } @found;
1477   for my $i (reverse 0 .. $#found-1) {
1478     if ($found[$i+1][0] - $found[$i][0] < $itemSize) {
1479       my @losing = @{$found[$i+1]};
1480       shift @losing;
1481       push(@{$found[$i]}, @losing);
1482       splice(@found, $i+1, 1); # remove it
1483     }
1484   }
1485
1486   my $highlight_prefix = 
1487     $cfg->entry('search highlight', "${type}_prefix", $cfg->entry('search highlight', "prefix", "<b>"));
1488   my $highlight_suffix =
1489     $cfg->entry('search highlight', "${type}_suffix", $cfg->entry('search highlight', "suffix", "</b>"));
1490   my $termSize = $excerptSize / @found;
1491   my $result = '';
1492   for my $term (@found) {
1493     my ($pos, @terms) = @$term;
1494     my $start = $pos - $termSize/2;
1495     my $part;
1496     if ($start < 0) {
1497       $start = 0;
1498       $part = substr($body, 0, $termSize);
1499     }
1500     else {
1501       $result .= "...";
1502       $part = substr($body, $start, $termSize);
1503       $part =~ s/^\w+//;
1504     }
1505     if ($start + $termSize < length $body) {
1506       $part =~ s/\s*\S*$/... /;
1507     }
1508     $result .= $part;
1509   }
1510   $result =~ s{$re}{$highlight_prefix$1$highlight_suffix}ig;
1511   $$found = 1;
1512
1513   return $result;
1514 }
1515
1516 sub visible {
1517   return 1;
1518 }
1519
1520
1521 # make whatever text $body points at safe for summarizing by removing most
1522 # block level formatting
1523 sub remove_block {
1524   my ($self, $articles, $acts, $body, $files) = @_;
1525
1526   my $formatter_class = $self->formatter_class;
1527
1528   $files ||= [];
1529
1530   my $formatter = $formatter_class->new(gen => $self, 
1531                                       acts => $acts, 
1532                                       article => $articles,
1533                                       articles => $articles,
1534                                       files => $files);
1535
1536   $$body = $formatter->remove_format($$body);
1537 }
1538
1539 sub _init_gimages {
1540   my ($self) = @_;
1541
1542   my @gimages = $self->site->images;
1543   $self->{gimages} = { map { $_->{name} => $_ } @gimages };
1544   $self->{gimages_a} = \@gimages;
1545 }
1546
1547 sub get_gimage {
1548   my ($self, $name) = @_;
1549
1550   unless ($self->{gimages}) {
1551     $self->_init_gimages;
1552   }
1553
1554   return $self->{gimages}{$name};
1555 }
1556
1557 sub get_gfile {
1558   my ($self, $name) = @_;
1559
1560   unless ($self->{gfiles}) {
1561     my @gfiles = BSE::TB::Articles->global_files;
1562     my %gfiles = map { $_->{name} => $_ } @gfiles;
1563     $self->{gfiles} = \%gfiles;
1564   }
1565
1566   return $self->{gfiles}{$name};
1567 }
1568
1569 # note: this is called by BSE::Formatter::thumbimage(), update that if
1570 # this is changed
1571 sub do_gthumbimage {
1572   my ($self, $geo_id, $image_id, $field, $current) = @_;
1573
1574   my $im;
1575   if ($image_id eq '-' && $current) {
1576     $im = $current;
1577   }
1578   else {
1579     $im = $self->get_gimage($image_id);
1580   }
1581   $im
1582     or return '** unknown global image id **';
1583
1584   return $self->_sthumbimage_low($geo_id, $im, $field);
1585 }
1586
1587 sub get_real_article {
1588   my ($self, $article) = @_;
1589
1590   return $article;
1591 }
1592
1593 sub localize {
1594   my ($self) = @_;
1595
1596   my $vars = $self->{vars};
1597   my %copy = %$vars;
1598   for my $key (keys %$vars) {
1599     if (ref $vars->{$key} && Scalar::Util::isweak($vars->{$key})) {
1600       Scalar::Util::weaken($copy{$key});
1601     }
1602   }
1603   push @{$self->{varstack}}, $vars;
1604   $self->{vars} = \%copy;
1605 }
1606
1607 sub unlocalize {
1608   my ($self) = @_;
1609
1610   $self->{vars} = pop @{$self->{varstack}};
1611 }
1612
1613 1;
1614
1615 __END__
1616
1617 =back
1618
1619 =head1 BUGS
1620
1621 Needs more documentation.
1622
1623 =cut