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