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