db7f03dcd663214ea6a91764fe984761e27a3845
[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.026";
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_tag {
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   return $self->_embed_low($embed, $articles, $template, $maxdepth);
517 }
518
519 sub _embed_low {
520   my ($self, $embed, $articles, $template, $maxdepth) = @_;
521
522   my $gen = $self;
523   if (ref($self) ne $embed->{generator}) {
524     my $genname = $embed->{generator};
525     $genname =~ s#::#/#g; # broken on MacOS I suppose
526     $genname .= ".pm";
527     eval {
528       require $genname;
529     };
530     if ($@) {
531       print STDERR "Cannot load generator $embed->{generator}: $@\n";
532       return "** Cannot load generator $embed->{generator} for article $embed->{id} **";
533     }
534     my $top = $self->{top} || $embed;
535     $gen = $embed->{generator}->new
536       (
537        admin=>$self->{admin},
538        admin_links => $self->{admin_links},
539        cfg=>$self->{cfg},
540        request=>$self->{request},
541        top=>$top
542       );
543   }
544
545   my $olddepth = $gen->{depth};
546   $gen->{depth} = $self->{depth}+1;
547   my $oldmaxdepth = $gen->{maxdepth};
548   $gen->{maxdepth} = $maxdepth;
549   $template = "" if defined($template) && $template eq "-";
550   my $result = $gen->embed($embed, $articles, $template);
551   $gen->{depth} = $olddepth;
552   $gen->{maxdepth} = $oldmaxdepth;
553
554   return $result;
555 }
556
557 sub formatter_class {
558   require BSE::Formatter::Article;
559   return 'BSE::Formatter::Article'
560 }
561
562 # replace markup, insert img tags
563 sub format_body {
564   my $self = shift;
565   my (%opts) =
566     (
567      abs_urls => 0, 
568      imagepos => 'tr', 
569      auto_images => 1,
570      images => [], 
571      files => [],
572      acts => {}, 
573      @_
574     );
575
576   my $acts = $opts{acts};
577   my $articles = $opts{articles};
578   my $body = $opts{text};
579   my $imagePos = $opts{imagepos};
580   my $abs_urls = $opts{abs_urls};
581   my $auto_images = $opts{auto_images};
582   my $templater = $opts{templater};
583   my $images = $opts{images};
584   my $files = $opts{files};
585
586   return substr($body, 6) if $body =~ /^<html>/i;
587
588   my $formatter_class = $self->formatter_class;
589
590   my $formatter = $formatter_class->new(gen => $self, 
591                                         acts => $acts, 
592                                         articles => $articles,
593                                         abs_urls => $abs_urls, 
594                                         auto_images => \$auto_images,
595                                         images => $images, 
596                                         files => $files,
597                                         templater => $templater);
598
599   $body = $formatter->format($body);
600
601   my $xhtml = $self->{cfg}->entry('basic', 'xhtml', 1);
602
603   # we don't format named images
604   my @images = grep $_->{name} eq '', @$images;
605   if ($auto_images
606       && @images
607       && $self->{cfg}->entry('basic', 'auto_images', 1)
608       && $imagePos ne 'xx') {
609     # the first image simply goes where we're told to put it
610     # the imagePos is [tb][rl] (top|bottom)(right|left)
611     my $align = $imagePos =~ /r/ ? 'right' : 'left';
612
613     # Offset the end a bit so we don't get an image hanging as obviously
614     # off the end.
615     # Numbers determined by trial - it can still look pretty rough.
616     my $len = length $body;
617     if ($len > 1000) {
618       $len -= 500; 
619     }
620     elsif ($len > 800) {
621       $len -= 200;
622     }
623
624     #my $incr = @images > 1 ? 2*$len / (2*@images+1) : 0;
625     my $incr = $len / @images;
626     # inserting the image tags moves character positions around
627     # so we need the temp buffer
628     if ($imagePos =~ /b/) {
629       @images = reverse @images;
630       if (@images % 2 == 0) {
631         # starting at the bottom, swap it around
632         $align = $align eq 'right' ? 'left' : 'right';
633       }
634     }
635     my $output = '';
636     for my $image (@images) {
637       # adjust to make sure this isn't in the middle of a tag or entity
638       my $pos = $self->adjust_for_html($body, $incr);
639       
640       my $img = $image->inline(cfg => $self->{cfg}, align => $align);
641       $output .= $img;
642       $output .= substr($body, 0, $pos);
643       substr($body, 0, $pos) = '';
644       $align = $align eq 'right' ? 'left' : 'right';
645     }
646     $body = $output . $body; # don't forget the rest of it
647   }
648   
649   return make_entities($body);
650 }
651
652 sub embed {
653   my ($self, $article, $articles, $template) = @_;
654
655   if (defined $template && $template =~ /\$/) {
656     $template =~ s/\$/$article->{template}/;
657   }
658   else {
659     $template = $article->{template}
660       unless defined($template) && $template =~ /\S/;
661   }
662
663   my $html = BSE::Template->get_source($template, $self->{cfg});
664
665   # the template will hopefully contain <:embed start:> and <:embed end:>
666   # tags
667   # otherwise pull out the body content
668   if ($html =~ /<:\s*embed\s*start\s*:>(.*)<:\s*embed\s*end\s*:>/s
669      || $html =~ m"<\s*body[^>]*>(.*)<\s*/\s*body>"s) {
670     $html = $1;
671   }
672   return $self->generate_low($html, $article, $articles, 1);
673 }
674
675 =item vembed(article)
676
677 =item vembed(article, template)
678
679 Embed the specified article using either the article template or the
680 specified template.
681
682 =back
683
684 =head1 GENERATOR TAGS
685
686 =over
687
688 =cut
689
690
691 sub vembed {
692   my ($self, $article, $template) = @_;
693
694   return $self->embed($article, "BSE::TB::Articles", $template);
695 }
696
697 sub iter_kids_of {
698   my ($self, $state, $args, $acts, $name, $templater) = @_;
699
700   my $filter = $self->_get_filter(\$args);
701
702   $state->{parentid} = undef;
703   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
704   for my $id (@ids) {
705     unless ($id =~ /^\d+$|^-1$/) {
706       $id = $templater->perform($acts, $id, "id");
707     }
708   }
709   @ids = grep /^\d+$|^-1$/, @ids;
710   if (@ids == 1) {
711     $state->{parentid} = $ids[0];
712   }
713   $self->_do_filter($filter, map BSE::TB::Articles->listedChildren($_), @ids);
714 }
715
716 my $cols_re; # cache for below
717
718 {
719   my %expr_cache;
720
721   sub _get_filter {
722     my ($self, $rargs) = @_;
723     
724     if ($$rargs =~ s/filter:\s+(.*)\z//s) {
725       my $expr = $1;
726       my $orig_expr = $expr;
727       unless ($cols_re) {
728         my $cols_expr = '(' . join('|', BSE::TB::Article->columns) . ')';
729         $cols_re = qr/\[$cols_expr\]/;
730       }
731       $expr =~ s/$cols_re/\$article->{$1}/g;
732       $expr =~ s/ARTICLE/\$article/g;
733       #print STDERR "Expr $expr\n";
734       my $filter = $expr_cache{$expr};
735       unless ($filter) {
736         $filter = eval 'sub { my $article = shift; '.$expr.'; }';
737         if ($@) {
738           print STDERR "** Failed to compile filter expression >>$expr<< built from >>$orig_expr<<\n";
739           return;
740         }
741         $expr_cache{$expr} = $filter;
742       }
743       
744       return $filter;
745     }
746     else {
747       return;
748     }
749   }
750 }
751
752 sub _do_filter {
753   my ($self, $filter, @articles) = @_;
754
755   $filter
756     or return @articles;
757
758   return grep $filter->($_), @articles;
759 }
760
761 sub iter_all_kids_of {
762   my ($self, $state, $args, $acts, $name, $templater) = @_;
763
764   my $filter = $self->_get_filter(\$args);
765
766   $state->{parentid} = undef;
767   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
768   for my $id (@ids) {
769     unless ($id =~ /^\d+$|^-1$/) {
770       $id = $templater->perform($acts, $id, "id");
771     }
772   }
773   @ids = grep /^\d+$|^-1$/, @ids;
774   @ids == 1 and $state->{parentid} = $ids[0];
775     
776   $self->_do_filter($filter, map BSE::TB::Articles->all_visible_kids($_), @ids);
777 }
778
779 sub iter_inlines {
780   my ($self, $state, $args, $acts, $name, $templater) = @_;
781
782   my $filter = $self->_get_filter(\$args);
783
784   $state->{parentid} = undef;
785   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
786   for my $id (@ids) {
787     unless ($id =~ /^\d+$/) {
788       $id = $templater->perform($acts, $id, "id");
789     }
790   }
791   @ids = grep /^\d+$/, @ids;
792   @ids == 1 and $state->{parentid} = $ids[0];
793
794   $self->_do_filter($filter, map BSE::TB::Articles->getByPkey($_), @ids);
795 }
796
797 sub iter_gimages {
798   my ($self, $args) = @_;
799
800   unless ($self->{gimages}) {
801     $self->_init_gimages;
802   }
803
804   if ($args =~ m!^named\s+/([^/]+)/$!) {
805     my $re = $1;
806     return grep $_->{name} =~ /$re/i, @{$self->{gimages_a}};
807   }
808   else {
809     return @{$self->{gimages_a}};
810   }
811 }
812
813 sub iter_gfiles {
814   my ($self, $args) = @_;
815
816   unless ($self->{gfiles}) {
817     my @gfiles = BSE::TB::Articles->global_files;
818     my %gfiles = map { $_->{name} => $_ } @gfiles;
819     $self->{gfiles} = \%gfiles;
820   }
821
822   my @gfiles = 
823     sort { $a->{name} cmp $b->{name} } values %{$self->{gfiles}};
824   if ($args =~ m!^named\s+/([^/]+)/$!) {
825     my $re = $1;
826     return grep $_->{name} =~ /$re/i, @gfiles;
827   }
828   elsif ($args =~ m(^filter: (.*)$)s) {
829     my $expr = $1;
830     $expr =~ s/FILE\[(\w+)\]/\$file->$1/g;
831     my $sub = eval 'sub { my $file = shift; ' . $expr . '; }';
832     $sub
833       or die "* Cannot compile sub from filter $expr: $@ *";
834     return grep $sub->($_), @gfiles;
835   }
836   else {
837     return @gfiles;
838   }
839 }
840
841 sub admin_tags {
842   my ($self) = @_;
843
844   $self->{admin} or return;
845
846   return BSE::Util::Tags->secure($self->{request});
847 }
848
849 sub _static_images {
850   my ($self) = @_;
851
852   my $static = $self->{cfg}->entry('basic', 'static_thumbnails', 1);
853   $self->{admin} and $static = 0;
854   $self->{dynamic} and $static = 0;
855
856   return $static;
857 }
858
859 # implements popimage and gpopimage
860 sub do_popimage_low {
861   my ($self, $im, $class) = @_;
862
863   return $im->popimage
864     (
865      cfg => $self->cfg,
866      class => $class,
867      static => $self->_static_images,
868     );
869
870 }
871
872 sub do_gpopimage {
873   my ($self, $image_id, $class) = @_;
874
875   my $im = $self->get_gimage($image_id)
876     or return "* Unknown global image '$image_id' *";
877
878   return $self->do_popimage_low($im, $class);
879 }
880
881 sub _sthumbimage_low {
882   my ($self, $geometry, $im, $field) = @_;
883
884   return $self->_thumbimage_low($geometry, $im, $field, $self->{cfg}, $self->_static_images);
885 }
886
887 sub tag_gthumbimage {
888   my ($self, $rcurrent, $args, $acts, $name, $templater) = @_;
889
890   my ($geometry_id, $id, $field) = DevHelp::Tags->get_parms($args, $acts, $templater);
891
892   return $self->do_gthumbimage($geometry_id, $id, $field, $$rcurrent);
893 }
894
895 sub _find_image {
896   my ($self, $acts, $templater, $article_id, $image_tags, $msg) = @_;
897
898   my $article;
899   if ($article_id =~ /^\d+$/) {
900     require BSE::TB::Articles;
901     $article = BSE::TB::Articles->getByPkey($article_id);
902     unless ($article) {
903       $$msg = "* no article $article_id found *";
904       return;
905     }
906   }
907   elsif ($acts->{$article_id}) {
908     my $id = $templater->perform($acts, $article_id, "id");
909     $article = BSE::TB::Articles->getByPkey($id);
910     unless ($article) {
911       $$msg = "* article $article_id/$id not found *";
912       return;
913     }
914   }
915   else {
916     ($article) = BSE::TB::Articles->getBy(linkAlias => $article_id);
917     unless ($article) {
918       $$msg = "* no article $article_id found *";
919       return;
920     }
921   }
922   $article
923     or return;
924
925   my @images = $article->images;
926   my $im;
927   for my $tag (split /,/, $image_tags) {
928     if ($tag =~ m!^/(.*)/$!) {
929       my $re = $1;
930       ($im) = grep $_->{name} =~ /$re/i, @images
931         and last;
932     }
933     elsif ($tag =~ /^\d+$/) {
934       if ($tag >= 1 && $tag <= @images) {
935         $im = $images[$tag-1];
936         last;
937       }
938     }
939     elsif ($tag =~ /^[^\W\d]\w*$/) {
940       ($im) = grep $_->{name} eq $tag, @images
941         and last;
942     }
943   }
944   unless ($im) {
945     $$msg = "* no image matching $image_tags found *";
946     return;
947   }
948
949   return $im;
950 }
951
952 sub tag_sthumbimage {
953   my ($self, $args, $acts, $name, $templater) = @_;
954
955   my ($article_id, $geometry, $image_tags, $field) = split ' ', $args;
956
957   my $msg;
958   my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
959     or return $msg;
960   
961   return $self->_sthumbimage_low($geometry, $im, $field);
962 }
963
964 sub tag_simage {
965   my ($self, $args, $acts, $name, $templater) = @_;
966
967   my ($article_id, $image_tags, $field, $rest) = split ' ', $args, 4;
968
969   my $msg;
970   my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
971     or return $msg;
972
973   return $self->_format_image($im, $field, $rest);
974 }
975
976 =item iterator vimages I<articles> I<filter>
977
978 =item iterator vimages I<articles>
979
980 Iterates over the images belonging to the articles specified.
981
982 I<articles> can be any of:
983
984 =over
985
986 =item *
987
988 article - the current article
989
990 =item *
991
992 children - all visible children (including stepkids) of the current
993 article
994
995 =item *
996
997 parent - the parent of the current article
998
999 =item *
1000
1001 I<number> - a numeric article id, such as C<10>.
1002
1003 =item *
1004
1005 alias(I<alias>) - a link alias of an article
1006
1007 =item *
1008
1009 childrenof(I<articles>) - an articles that are children of
1010 I<articles>.  I<articles> can be any normal article spec, so
1011 C<childrenof(childrenof(-1))> is valid.
1012
1013 =item *
1014
1015 I<tagname> - a tag name referring to an article.
1016
1017 =back
1018
1019 I<articles> has [] replacement done before parsing.
1020
1021 I<filter> can be missing, or either of:
1022
1023 =over
1024
1025 =item *
1026
1027 named /I<regexp>/ - images with names matching the given regular
1028 expression
1029
1030 =item *
1031
1032 numbered I<number> - images with the given index.
1033
1034 =back
1035
1036 Items for this iterator are vimage and vthumbimage.
1037
1038 =cut
1039
1040 sub iter_vimages {
1041   my ($self, $article, $args, $acts, $name, $templater) = @_;
1042
1043   my $re;
1044   my $num;
1045   if ($args =~ s!\s+named\s+/([^/]+)/$!!) {
1046     $re = $1;
1047   }
1048   elsif ($args =~ s!\s+numbered\s+(\d+)$!!) {
1049     $num = $1;
1050   }
1051   my @args = DevHelp::Tags->get_parms($args, $acts, $templater);
1052   my @images;
1053   for my $article_id (map { split /[, ]/ } @args) {
1054     my @articles = $self->_find_articles($article_id, $article, $acts, $name, $templater);
1055     for my $article (@articles) {
1056       my @aimages = $article->images;
1057       if (defined $re) {
1058         push @images, grep $_->{name} =~ /$re/, @aimages;
1059       }
1060       elsif (defined $num) {
1061         if ($num >= 0 && $num <= @aimages) {
1062           push @images, $aimages[$num-1];
1063         }
1064       }
1065       else {
1066         push @images, @aimages;
1067       }
1068     }
1069   }
1070
1071   return @images;
1072 }
1073
1074 =item vimage field
1075
1076 =item vimage
1077
1078 Retrieve the given field from the current vimage, or display the image.
1079
1080 =cut
1081
1082 sub tag_vimage {
1083   my ($self, $rvimage, $args) = @_;
1084
1085   $$rvimage or return '** no current vimage **';
1086
1087   my ($field, $rest) = split ' ', $args, 2;
1088
1089   return $self->_format_image($$rvimage, $field, $rest);
1090 }
1091
1092 =item vthumbimage geometry field
1093
1094 =item vthumbimage geometry
1095
1096 Retrieve the given field from the thumbnail of the current vimage or
1097 display the thumbnail.
1098
1099 =cut
1100
1101 sub tag_vthumbimage {
1102   my ($self, $rvimage, $args) = @_;
1103
1104   $$rvimage or return '** no current vimage **';
1105   my ($geo, $field) = split ' ', $args;
1106
1107   return $self->_sthumbimage_low($geo, $$rvimage, $field);
1108 }
1109
1110 sub _find_articles {
1111   my ($self, $article_id, $article, $acts, $name, $templater) = @_;
1112
1113   if ($article_id =~ /^\d+$/) {
1114     my $result = BSE::TB::Articles->getByPkey($article_id);
1115     $result or print STDERR "** Unknown article id $article_id **\n";
1116     return $result ? $result : ();
1117   }
1118   elsif ($article_id =~ /^alias\((\w+)\)$/) {
1119     my $result = BSE::TB::Articles->getBy(linkAlias => $1);
1120     $result or print STDERR "** Unknown article alias $article_id **\n";
1121     return $result ? $result : ();
1122   }
1123   elsif ($article_id =~ /^childrenof\((.*)\)$/) {
1124     my $id = $1;
1125     if ($id eq '-1') {
1126       return BSE::TB::Articles->all_visible_kids(-1);
1127     }
1128     else {
1129       my @parents = $self->_find_articles($id, $article, $acts, $name, $templater)
1130         or return;
1131       return map $_->all_visible_kids, @parents;
1132     }
1133   }
1134   elsif ($acts->{$article_id}) {
1135     my $id = $templater->perform($acts, $article_id, 'id');
1136     if ($id && $id =~ /^\d+$/) {
1137       return BSE::TB::Articles->getByPkey($id);
1138     }
1139   }
1140   print STDERR "** Unknown article identifier $article_id **\n";
1141
1142   return;
1143 }
1144
1145 sub baseActs {
1146   my ($self, $articles, $acts, $article, $embedded) = @_;
1147
1148   # used to generate the side menu
1149   my $section_index = -1;
1150   my @sections = $articles->listedChildren(-1);
1151     #sort { $a->{displayOrder} <=> $b->{displayOrder} } 
1152     #grep $_->{listed}, $articles->sections;
1153   my $subsect_index = -1;
1154   my @subsections; # filled as we move through the sections
1155   my @level3; # filled as we move through the subsections
1156   my $level3_index = -1;
1157
1158   my $cfg = $self->{cfg} || BSE::Cfg->single;
1159   my %extras = $cfg->entriesCS('extra tags');
1160   for my $key (keys %extras) {
1161     # follow any links
1162     my $data = $cfg->entryVar('extra tags', $key);
1163     $extras{$key} = sub { $data };
1164   }
1165
1166   my $current_gimage;
1167   my $current_vimage;
1168   my $it = BSE::Util::Iterate->new;
1169   my $art_it = BSE::Util::Iterate::Article->new(cfg => $cfg,
1170                                                 admin => $self->{admin},
1171                                                 top => $self->{top});
1172   my $weak_self = $self;
1173   Scalar::Util::weaken($weak_self);
1174   $self->set_variable(url => sub { $weak_self->url(@_) });
1175   return 
1176     (
1177      %extras,
1178
1179      custom_class($cfg)->base_tags($articles, $acts, $article, $embedded, $cfg, $self),
1180      $self->admin_tags(),
1181      BSE::Util::Tags->static($acts, $self->{cfg}),
1182      # for embedding the content from children and other sources
1183      ifEmbedded=> sub { $embedded },
1184      embed => sub {
1185        my ($args, $acts, $name, $templater) = @_;
1186        return '' if $args eq 'start' || $args eq 'end';
1187        my ($what, $template, $maxdepth) = split ' ', $args;
1188        undef $maxdepth if defined $maxdepth && $maxdepth !~ /^\d+/;
1189        return $self->_embed_tag($acts, $articles, $what, $template, $maxdepth, $templater);
1190      },
1191      ifCanEmbed=> sub { $self->{depth} <= $self->{maxdepth} },
1192
1193      summary =>
1194      sub {
1195        my ($args, $acts, $name, $templater) = @_;
1196        my ($which, $limit) = DevHelp::Tags->get_parms($args, $acts, $templater);
1197        $which or $which = "child";
1198        $limit or $limit = $article->{summaryLength};
1199        $acts->{$which}
1200          or return "<:summary $which Cannot find $which:>";
1201        my $id = $templater->perform($acts, $which, "id")
1202          or return "<:summary $which No id returned :>";
1203        my $article = $articles->getByPkey($id)
1204          or return "<:summary $which Cannot find article $id:>";
1205        return $self->summarize($articles, $article->{body}, $acts, $limit);
1206      },
1207      ifAdmin => sub { $self->{admin} },
1208      ifAdminLinks => sub { $self->{admin_links} },
1209      
1210      # for generating the side menu
1211      iterate_level1_reset => sub { $section_index = -1 },
1212      iterate_level1 => sub {
1213        ++$section_index;
1214        if ($section_index < @sections) {
1215          #@subsections = grep $_->{listed}, 
1216          #  $articles->children($sections[$section_index]->{id});
1217          @subsections = grep { $_->{listed} != 2 }
1218            $articles->listedChildren($sections[$section_index]->{id});
1219          $subsect_index = -1;
1220          return 1;
1221        }
1222        else {
1223          return 0;
1224        }
1225      },
1226      level1 => sub {
1227        return tag_article($sections[$section_index], $cfg, $_[0]);
1228      },
1229
1230      # used to generate a list of subsections for the side-menu
1231      iterate_level2 => sub {
1232        ++$subsect_index;
1233        if ($subsect_index < @subsections) {
1234          @level3 = grep { $_->{listed} != 2 }
1235            $articles->listedChildren($subsections[$subsect_index]{id});
1236          $level3_index = -1;
1237          return 1;
1238        }
1239        return 0;
1240      },
1241      level2 => sub {
1242        return tag_article($subsections[$subsect_index], $cfg, $_[0]);
1243      },
1244      ifLevel2 => 
1245      sub {
1246        return scalar @subsections;
1247      },
1248      
1249      # possibly level3 items
1250      iterate_level3 => sub {
1251        return ++$level3_index < @level3;
1252      },
1253      level3 => sub { 
1254        tag_article($level3[$level3_index], $cfg, $_[0])
1255      },
1256      ifLevel3 => sub { scalar @level3 },
1257
1258      # generate an admin or link url, depending on admin state
1259      url=>
1260      sub {
1261        my ($name, $acts, $func, $templater) = @_;
1262        my $item = $self->{admin_links} ? 'admin' : 'link';
1263        $acts->{$name}
1264          or die "ENOIMPL\n";
1265        my $url = $templater->perform($acts, $name, $item);
1266        if (!$self->{admin} && $self->{admin_links}) {
1267          $url .= $url =~ /\?/ ? "&" : "?";
1268          $url .= "admin=0&admin_links=1";
1269        }
1270        return $url;
1271      },
1272      ifInMenu =>
1273      sub {
1274        $acts->{$_[0]} or return 0;
1275        return $acts->{$_[0]}->('listed') == 1;
1276      },
1277      titleImage=>
1278      sub {
1279        my ($image, $text) = split ' ', $_[0];
1280
1281        my $image_dir = cfg_image_dir();
1282        if (-e "$image_dir/titles/$image") {
1283          my $image_uri = cfg_image_uri();
1284          return qq!<img src="$image_uri/titles/!.$image .qq!" border=0>!
1285        }
1286        else {
1287          return escape_html($text);
1288        }
1289      },
1290      $art_it->make( code => [ iter_kids_of => $self ],
1291                     single => 'ofchild',
1292                     plural => 'children_of', 
1293                     nocache => 1,
1294                     state => 1 ), 
1295      $art_it->make( code => [ iter_kids_of => $self ],
1296                     single => 'ofchild2',
1297                     plural => 'children_of2',
1298                     nocache => 1,
1299                     state => 1 ),
1300      $art_it->make( code => [ iter_kids_of => $self ],
1301                     single => 'ofchild3',
1302                     plural => 'children_of3',
1303                     nocache => 1,
1304                     state => 1 ),
1305      $art_it->make( code => [ iter_all_kids_of => $self ], 
1306                     single => 'ofallkid',
1307                     plural => 'allkids_of',
1308                     state => 1 ), 
1309      $art_it->make( code => [ iter_all_kids_of => $self ],
1310                     single => 'ofallkid2', 
1311                     plural => 'allkids_of2', 
1312                     nocache => 1,
1313                     state => 1 ), 
1314      $art_it->make( code => [ iter_all_kids_of => $self ],
1315                     single => 'ofallkid3',
1316                     plural => 'allkids_of3',
1317                     nocache => 1,
1318                     state => 1 ), 
1319      $art_it->make( code => [ iter_all_kids_of => $self ],
1320                     single => 'ofallkid4',
1321                     plural => 'allkids_of4',
1322                     nocache => 1,
1323                     state => 1 ), 
1324      $art_it->make( code => [ iter_all_kids_of => $self ],
1325                     single => 'ofallkid5',
1326                     plural => 'allkids_of5',
1327                     nocache => 1,
1328                     state => 1 ), 
1329      $art_it->make( code => [ iter_inlines => $self ],
1330                     single => 'inline',
1331                     plural => 'inlines',
1332                     nocache => 1,
1333                     state => 1 ), 
1334      gimage => 
1335      sub {
1336        my ($args, $acts, $func, $templater) = @_;
1337        my ($name, $align, @rest) = 
1338          DevHelp::Tags->get_parms($args, $acts, $templater);
1339        my $rest = "@rest";
1340
1341        my $im;
1342        defined $name && length $name
1343          or return '* missing or empty name parameter for gimage *';
1344        if ($name eq '-') {
1345          $im = $current_gimage
1346            or return '';
1347        }
1348        else {
1349          $im = $self->get_gimage($name)
1350            or return '';
1351        }
1352
1353        $self->_format_image($im, $align, $rest);
1354      },
1355      $it->make_iterator( [ \&iter_gimages, $self ], 'gimagei', 'gimages', 
1356                          undef, undef, undef, \$current_gimage),
1357      gfile => 
1358      sub {
1359        my ($name, $field) = split ' ', $_[0], 3;
1360
1361        my $file = $self->get_gfile($name)
1362          or return '';
1363
1364        $self->_format_file($file, $field);
1365      },
1366      $it->make_iterator( [ \&iter_gfiles, $self ], 'gfilei', 'gfiles'),
1367      gthumbimage => [ tag_gthumbimage => $self, \$current_gimage ],
1368      sthumbimage => [ tag_sthumbimage => $self ],
1369      simage => [ tag_simage => $self ],
1370      $it->make_iterator( [ iter_vimages => $self, $article ], 'vimage', 'vimages', undef, undef, undef, \$current_vimage),
1371      vimage => [ tag_vimage => $self, \$current_vimage ],
1372      vthumbimage => [ tag_vthumbimage => $self, \$current_vimage ],
1373     );
1374 }
1375
1376 sub _highlight_partial {
1377   my ($self) = @_;
1378
1379   $self->{cfg}->entryBool('search', 'highlight_partial', 1);
1380 }
1381
1382 sub find_terms {
1383   my ($self, $body, $case_sensitive, $terms) = @_;
1384
1385   my $eow = $self->_highlight_partial ? "" : qr/\b/;
1386   # locate the terms
1387   my @found;
1388   if ($case_sensitive) {
1389     for my $term (@$terms) {
1390       if ($$body =~ /^(.*?)\b\Q$term\E$eow/s) {
1391         push(@found, [ length($1), $term ]);
1392       }
1393     }
1394   }
1395   else {
1396     for my $term (@$terms) {
1397       if ($$body =~ /^(.*?)\b\Q$term\E$eow/is) {
1398         push(@found, [ length($1), $term ]);
1399       }
1400     }
1401   }
1402
1403   return @found;
1404 }
1405
1406 # this takes the same inputs as _make_table(), but eliminates any
1407 # markup instead
1408 sub _cleanup_table {
1409   my ($opts, $data) = @_;
1410   my @lines = split /\n/, $data;
1411   for (@lines) {
1412     s/^[^|]*\|//;
1413     tr/|/ /s;
1414   }
1415   return join(' ', @lines);
1416 }
1417
1418 # produce a nice excerpt for a found article
1419 sub excerpt {
1420   my ($self, $article, $found, $case_sensitive, $terms, $type, $body) = @_;
1421
1422   if (!$body) {
1423     $body = $article->{body};
1424     
1425     # we remove any formatting tags here, otherwise we get wierd table
1426     # rubbish or other formatting in the excerpt.
1427     my @files = $article->files;
1428     $self->remove_block('BSE::TB::Articles', [], \$body, \@files);
1429     1 while $body =~ s/[bi]\[([^\]\[]+)\]/$1/g;
1430   }
1431     
1432   $body = escape_html($body);
1433
1434   $type ||= 'body';
1435
1436   my @found = $self->find_terms(\$body, $case_sensitive, $terms);
1437
1438   my @reterms = @$terms;
1439   for (@reterms) {
1440     tr/ / /s;
1441     $_ = quotemeta;
1442     s/\\?\s+/\\s+/g;
1443   }
1444   # do a reverse sort so that the longer terms (and composite
1445   # terms) are replaced first
1446   my $re_str = join("|", reverse sort @reterms);
1447   my $re;
1448   my $cfg = $self->{cfg};
1449   if ($self->_highlight_partial) {
1450     $re = $case_sensitive ? qr/\b($re_str)/ : qr/\b($re_str)/i;
1451   }
1452   else {
1453     $re = $case_sensitive ? qr/\b($re_str)\b/ : qr/\b($re_str)\b/i;
1454   }
1455
1456   # this used to try searching children as well, but it broke more
1457   # than it fixed
1458   if (!@found) {
1459     # we tried hard and failed
1460     # return a generic article
1461     if (length $body > $excerptSize) {
1462       $body = substr($body, 0, $excerptSize);
1463       $body =~ s/\S+\s*$/.../;
1464     }
1465     $$found = 0;
1466     return $body;
1467   }
1468
1469   # only the first 5
1470   splice(@found, 5,-1) if @found > 5;
1471   my $itemSize = $excerptSize / @found;
1472
1473   # try to combine any that are close
1474   @found = sort { $a->[0] <=> $b->[0] } @found;
1475   for my $i (reverse 0 .. $#found-1) {
1476     if ($found[$i+1][0] - $found[$i][0] < $itemSize) {
1477       my @losing = @{$found[$i+1]};
1478       shift @losing;
1479       push(@{$found[$i]}, @losing);
1480       splice(@found, $i+1, 1); # remove it
1481     }
1482   }
1483
1484   my $highlight_prefix = 
1485     $cfg->entry('search highlight', "${type}_prefix", $cfg->entry('search highlight', "prefix", "<b>"));
1486   my $highlight_suffix =
1487     $cfg->entry('search highlight', "${type}_suffix", $cfg->entry('search highlight', "suffix", "</b>"));
1488   my $termSize = $excerptSize / @found;
1489   my $result = '';
1490   for my $term (@found) {
1491     my ($pos, @terms) = @$term;
1492     my $start = $pos - $termSize/2;
1493     my $part;
1494     if ($start < 0) {
1495       $start = 0;
1496       $part = substr($body, 0, $termSize);
1497     }
1498     else {
1499       $result .= "...";
1500       $part = substr($body, $start, $termSize);
1501       $part =~ s/^\w+//;
1502     }
1503     if ($start + $termSize < length $body) {
1504       $part =~ s/\s*\S*$/... /;
1505     }
1506     $result .= $part;
1507   }
1508   $result =~ s{$re}{$highlight_prefix$1$highlight_suffix}ig;
1509   $$found = 1;
1510
1511   return $result;
1512 }
1513
1514 sub visible {
1515   return 1;
1516 }
1517
1518
1519 # make whatever text $body points at safe for summarizing by removing most
1520 # block level formatting
1521 sub remove_block {
1522   my ($self, $articles, $acts, $body, $files) = @_;
1523
1524   my $formatter_class = $self->formatter_class;
1525
1526   $files ||= [];
1527
1528   my $formatter = $formatter_class->new(gen => $self, 
1529                                       acts => $acts, 
1530                                       article => $articles,
1531                                       articles => $articles,
1532                                       files => $files);
1533
1534   $$body = $formatter->remove_format($$body);
1535 }
1536
1537 sub _init_gimages {
1538   my ($self) = @_;
1539
1540   my @gimages = $self->site->images;
1541   $self->{gimages} = { map { $_->{name} => $_ } @gimages };
1542   $self->{gimages_a} = \@gimages;
1543 }
1544
1545 sub get_gimage {
1546   my ($self, $name) = @_;
1547
1548   unless ($self->{gimages}) {
1549     $self->_init_gimages;
1550   }
1551
1552   return $self->{gimages}{$name};
1553 }
1554
1555 sub get_gfile {
1556   my ($self, $name) = @_;
1557
1558   unless ($self->{gfiles}) {
1559     my @gfiles = BSE::TB::Articles->global_files;
1560     my %gfiles = map { $_->{name} => $_ } @gfiles;
1561     $self->{gfiles} = \%gfiles;
1562   }
1563
1564   return $self->{gfiles}{$name};
1565 }
1566
1567 # note: this is called by BSE::Formatter::thumbimage(), update that if
1568 # this is changed
1569 sub do_gthumbimage {
1570   my ($self, $geo_id, $image_id, $field, $current) = @_;
1571
1572   my $im;
1573   if ($image_id eq '-' && $current) {
1574     $im = $current;
1575   }
1576   else {
1577     $im = $self->get_gimage($image_id);
1578   }
1579   $im
1580     or return '** unknown global image id **';
1581
1582   return $self->_sthumbimage_low($geo_id, $im, $field);
1583 }
1584
1585 sub get_real_article {
1586   my ($self, $article) = @_;
1587
1588   return $article;
1589 }
1590
1591 sub localize {
1592   my ($self) = @_;
1593
1594   my $vars = $self->{vars};
1595   my %copy = %$vars;
1596   for my $key (keys %$vars) {
1597     if (ref $vars->{$key} && Scalar::Util::isweak($vars->{$key})) {
1598       Scalar::Util::weaken($copy{$key});
1599     }
1600   }
1601   push @{$self->{varstack}}, $vars;
1602   $self->{vars} = \%copy;
1603 }
1604
1605 sub unlocalize {
1606   my ($self) = @_;
1607
1608   $self->{vars} = pop @{$self->{varstack}};
1609 }
1610
1611 1;
1612
1613 __END__
1614
1615 =back
1616
1617 =head1 BUGS
1618
1619 Needs more documentation.
1620
1621 =cut