_body_embed() isn't used, remove it
[bse.git] / site / cgi-bin / modules / BSE / Generate.pm
CommitLineData
9785c9c4 1package BSE::Generate;
41358dcc 2use strict;
e0ed81d7 3use BSE::TB::Articles;
771ab646 4use Constants qw($LOCAL_FORMAT $BODY_EMBED
d38f3b10 5 $EMBED_MAX_DEPTH $HAVE_HTML_PARSER);
7928764a 6use DevHelp::Tags;
3f9c8a96 7use BSE::Util::HTML;
c76e86ea 8use BSE::Util::Tags qw(tag_article);
771ab646 9use BSE::CfgInfo qw(custom_class cfg_image_dir cfg_image_uri);
b873a8fa 10use BSE::Util::Iterate;
599fe373 11use BSE::TB::Site;
234312d8 12use BSE::Variables;
75957b81 13use Scalar::Util ();
b864cc90 14use base 'BSE::ThumbLow';
47c75494 15use base 'BSE::TagFormats';
41358dcc 16
b3e1109c 17=head1 NAME
cb7fd78d 18
b3e1109c
TC
19Generate - provides base Squirel::Template actions for use in generating
20pages.
41358dcc 21
b3e1109c 22=head1 SYNOPSIS
599fe373 23
b3e1109c 24=head1 DESCRIPTION
41358dcc 25
b3e1109c 26This is probably better documented in L<templates.pod>.
8a153d74 27
b3e1109c 28=head1 VARIABLES
73b3a7aa 29
b3e1109c 30Template variables:
73b3a7aa 31
b3e1109c 32=over
73b3a7aa 33
b3e1109c 34=item *
73b3a7aa 35
b3e1109c 36url(article)
47e2aec7 37
b3e1109c 38=item *
599fe373 39
b3e1109c 40url(article, 1)
599fe373 41
b3e1109c
TC
42Return a URL for the given article, depending on admin_links mode. If
43the page is being generated with absolute URLs or a second true
44parameter is supplied, the URL is convrted to an absolute URL if
45necessary.
599fe373 46
b3e1109c 47=item *
599fe373 48
b3e1109c 49articles - the articles class.
599fe373 50
b3e1109c 51=item *
599fe373 52
b3e1109c 53generator - the generator object itself.
599fe373 54
b3e1109c 55=back
41358dcc 56
b3e1109c 57=head1 COMMON TAGS
41358dcc 58
b3e1109c
TC
59These tags can be used anywhere, including in admin templates. It's
60possible some admin code has been missed, if you find a place where
61these cannot be used let us know.
41358dcc 62
b3e1109c 63=over
721cd24c 64
b3e1109c 65=item kb I<data tag>
721cd24c 66
b3e1109c
TC
67Formats the give value in kI<whatevers>. If you have a number that
68could go over 1000 and you want it to use the 'k' metric prefix when
69it does, use this tag. eg. <:kb file sizeInBytes:>
721cd24c 70
b3e1109c 71=item date I<data tag>
721cd24c 72
b3e1109c 73=item date "I<format>" I<data tag>
721cd24c 74
b3e1109c
TC
75Formats a date or date/time value from the database into something
76more human readable. If you don't supply a format then the default
77format of "%d-%b-%Y" is used ("20-Mar-2002").
721cd24c 78
b3e1109c
TC
79The I<format> is a strftime() format specification, if that means
80anything to you. If it doesn't, each code starts with % and are
81replaced as follows:
85802bd5 82
b3e1109c 83=over
721cd24c 84
b3e1109c 85=item %a
cf23a1c7 86
b3e1109c 87abbreviated weekday name
cf23a1c7 88
b3e1109c 89=item %A
cf23a1c7 90
b3e1109c 91full weekday name
41358dcc 92
b3e1109c 93=item %b
41358dcc 94
b3e1109c 95abbreviated month name
41358dcc 96
b3e1109c 97=item %B
8aee8e95 98
b3e1109c 99full month name
745d2b57 100
b3e1109c 101=item %c
745d2b57 102
b3e1109c 103"preferred" date and time representation
745d2b57 104
b3e1109c 105=item %d
201aed6f 106
b3e1109c 107day of the month as a 2 digit number
201aed6f 108
b3e1109c 109=item %H
201aed6f 110
b3e1109c 111hour (24-hour clock)
745d2b57 112
b3e1109c 113=item %I
745d2b57 114
b3e1109c 115hour (12-hour clock)
745d2b57 116
b3e1109c 117=item %j
745d2b57 118
b3e1109c 119day of year as a 3-digit number
2fc9c38a 120
b3e1109c 121=item %m
c5286ebe 122
b3e1109c 123month as a 2 digit number
41358dcc 124
b3e1109c 125=item %M
41358dcc 126
b3e1109c 127minute as a 2 digit number
4772671f 128
b3e1109c 129=item %p
4772671f 130
b3e1109c 131AM or PM or their equivalents
41358dcc 132
b3e1109c 133=item %S
0ef1d253 134
b3e1109c 135seconds as a 2 digit number
41358dcc 136
b3e1109c 137=item %U
41358dcc 138
b3e1109c 139week number as a 2 digit number (first Sunday as the first day of week 1)
41358dcc 140
b3e1109c 141=item %w
c76e86ea 142
b3e1109c 143weekday as a decimal number (0-6)
8aee8e95 144
b3e1109c 145=item %W
8aee8e95 146
b3e1109c 147week number as a 2 digit number (first Monday as the first day of week 1)
8aee8e95 148
b3e1109c 149=item %x
75957b81 150
b3e1109c 151the locale's appropriate date representation
75957b81 152
b3e1109c 153=item %X
7d8d0f14 154
b3e1109c 155the locale's appropriate time representation
7928764a 156
b3e1109c 157=item %y
7928764a 158
b3e1109c 1592-digit year without century
70789617 160
b3e1109c 161=item %Y
0804976d 162
b3e1109c 163the full year
70789617 164
b3e1109c 165=item %Z
70789617 166
b3e1109c 167time zone name or abbreviation
70789617 168
b3e1109c 169=item %%
70789617 170
b3e1109c 171just '%'
70789617 172
b3e1109c 173=back
aefcabcb 174
b3e1109c
TC
175Your local strftime() implementation may implement some extensions to
176the above, if your server is on a Unix system try running "man
177strftime" for more information.
aefcabcb 178
b3e1109c 179=item bodytext I<data tag>
0316d3da 180
b3e1109c 181Formats the text from the given tag in the same way that body text is.
7928764a 182
b3e1109c 183=item ifEq I<data1> I<data2>
0316d3da 184
b3e1109c
TC
185Checks if the 2 values are exactly equal. This is a string
186comparison.
7928764a 187
b3e1109c
TC
188The 2 data parameters can either be a tag reference in [], a literal
189string inside "" or a single word.
e6ce1340 190
b3e1109c 191=item ifMatch I<data1> I<data2>
e6ce1340 192
b3e1109c
TC
193Treats I<data2> as a perl regular expression and attempts to match
194I<data1> against it.
e6ce1340 195
b3e1109c
TC
196The 2 data parameters can either be a tag reference in [], a literal
197string inside "" or a single word.
9366cd70 198
b3e1109c 199=item cfg I<section> I<key>
9366cd70 200
b3e1109c 201=item cfg I<section> I<key> I<default>
7f05f584 202
b3e1109c 203Retrieves a value from the BSE configuration file.
7f05f584 204
b3e1109c 205If you don't supply a default then a default will be the empty string.
b902f9de 206
b3e1109c 207=item release
b902f9de 208
b3e1109c 209The release number of BSE.
8a153d74 210
b3e1109c 211=back
8a153d74 212
b3e1109c 213=head1 TAGS
8a153d74 214
b3e1109c 215=over 4
8a153d74 216
b3e1109c 217=item ifAdmin
8a153d74 218
b3e1109c 219Conditional tag, true if generating in admin mode.
8a153d74 220
b3e1109c 221=item iterator ... level1
8a153d74 222
b3e1109c 223Iterates over the listed level 1 articles.
8a153d74 224
b3e1109c 225=item level1 I<name>
b902f9de 226
b3e1109c 227The value of the I<name> field of the current level 1 article.
195977cd 228
b3e1109c 229=item iterator ... level2
195977cd 230
b3e1109c 231Iterates over the listed level 2 children of the current level 1 article.
195977cd 232
b3e1109c 233=item level2 I<name>
47f841b5 234
b3e1109c 235The value of the I<name> field of the current level 2 article.
47f841b5 236
b3e1109c 237=item ifLevel2 I<name>
a9b73dab 238
b3e1109c
TC
239Conditional tag, true if the current level 1 article has any listed
240level 2 children.
a9b73dab 241
b3e1109c 242=item iterator ... level3
a9b73dab 243
b3e1109c 244Iterates over the listed level 3 children of the current level 2 article.
a9b73dab 245
b3e1109c 246=item level3 I<name>
47f841b5 247
b3e1109c 248The value of the I<name> field of the current level 3 article.
a9b73dab 249
b3e1109c 250=item ifLevel3 I<name>
a9b73dab 251
b3e1109c
TC
252Conditional tag, true if the current level 2 article has any listed
253level 3 children.
a9b73dab 254
b3e1109c 255=item url I<which>
a9b73dab 256
b3e1109c
TC
257Returns a link to the specified article . Due to the way the action
258list is built, this can be article types defined in derived classes of
39e87dbd 259Generate, like the C<parent> article in BSE::Generate::Article.
47c75494 260
b3e1109c 261=item money I<data tag>
47c75494 262
b3e1109c
TC
263Formats the given value as a monetary value. This does not include a
264currency symbol. Internally BSE stores monetary values as integers to
265prevent the loss of accuracy inherent in floating point numbers. You
266need to use this tag to display any monetary value.
47c75494 267
b3e1109c 268=item ifInMenu I<which>
47c75494 269
b3e1109c 270Conditional tag, true if the given item can appear in a menu.
47c75494 271
b3e1109c 272=item titleImage I<imagename> I<text>
47c75494 273
b3e1109c
TC
274Generates an IMG tag if the given I<imagename> is in the title image
275directory (F<titles> in the managed images directory). If it doesn't
276exist, produce I<text>.
47c75494 277
b3e1109c 278=item embed I<which>
47c75494 279
b3e1109c 280=item embed I<which> I<template>
47c75494 281
b3e1109c 282=item embed I<which> I<template> I<maxdepth>
47c75494 283
b3e1109c 284=item embed child
47c75494 285
b3e1109c
TC
286Embeds the article specified by which using either the specified
287template or the articles template.
47c75494 288
b3e1109c 289In this case I<which> can also be an article ID.
47c75494 290
b3e1109c
TC
291I<template> is a filename relative to the templates directory. If
292this is "-" then the articles template is used (so you can set
293I<maxdepth> without setting the template.) If I<template> contains a
294C<$> sign it will be replaced with the name of the original template.
47c75494 295
b3e1109c
TC
296If I<maxdepth> is supplied and is less than the current maximum depth
297then it becomes the new maximum depth. This can be used with ifCanEmbed.
47c75494 298
b3e1109c 299=item embed start ... embed end
47c75494 300
b3e1109c
TC
301Marks the range of text that would be embedded in a parent that used
302C<embed child>.
47c75494 303
b3e1109c 304=item ifEmbedded
47c75494 305
b3e1109c 306Conditional tag, true if the current article is being embedded.
47c75494
TC
307
308=back
309
b3e1109c 310=head1 C<generator> METHODS
47c75494
TC
311
312=over
313
b3e1109c 314=cut
47c75494 315
03deec09 316our $VERSION = "1.025";
47c75494 317
b3e1109c 318my $excerptSize = 300;
47c75494 319
b3e1109c
TC
320sub 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;
e0ed81d7 336 $self->set_variable_class(articles => "BSE::TB::Articles");
b3e1109c
TC
337 $opts{vars}{generator} = $self;
338 Scalar::Util::weaken($opts{vars}{generator});
47c75494 339
b3e1109c
TC
340 return $self;
341}
47c75494 342
b3e1109c
TC
343sub cfg {
344 $_[0]{cfg};
345}
47c75494 346
03342186
TC
347sub request {
348 $_[0]{request};
349}
350
b3e1109c
TC
351sub url {
352 my ($self, $article, $force_abs) = @_;
47c75494 353
b3e1109c
TC
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 }
47c75494 359
b3e1109c
TC
360 if (($force_abs || $self->abs_urls($article)) && $url !~ /^\w+:/) {
361 $url = $self->cfg->entryErr("site", "url") . $url;
47c75494
TC
362 }
363
b3e1109c 364 return $url;
47c75494
TC
365}
366
b3e1109c
TC
367sub site {
368 my $self = shift;
369 $self->{site} ||= BSE::TB::Site->new;
370 return $self->{site};
371}
47c75494 372
b3e1109c
TC
373sub set_variable {
374 my ($self, $name, $value) = @_;
47c75494 375
b3e1109c 376 $self->{vars}{$name} = $value;
47c75494 377
b3e1109c
TC
378 return 1;
379}
47c75494 380
b3e1109c
TC
381sub set_variable_class {
382 my ($self, $name, $class) = @_;
47c75494 383
b3e1109c
TC
384 require Squirrel::Template;
385 $self->set_variable($name => Squirrel::Template::Expr::WrapClass->new($class));
386}
47c75494 387
b3e1109c
TC
388sub variables {
389 my ($self) = @_;
47c75494 390
b3e1109c 391 return $self->{vars};
47c75494
TC
392}
393
b3e1109c
TC
394# replace commonly used characters
395# like MS dumb-quotes
396# unfortunately some browsers^W^Wnetscape don't support the entities yet <sigh>
397sub make_entities {
398 my $text = shift;
47c75494 399
b3e1109c
TC
400 $text =~ s/\226/-/g; # "--" looks ugly
401 $text =~ s/\222/'/g;
402 $text =~ s/\221/`/g;
403 $text =~ s/\&#8217;/'/g;
47c75494 404
b3e1109c
TC
405 return $text;
406}
47c75494 407
b3e1109c
TC
408sub summarize {
409 my ($self, $articles, $text, $acts, $length) = @_;
47c75494 410
b3e1109c
TC
411 # remove any block level formatting
412 $self->remove_block($articles, $acts, \$text);
47c75494 413
b3e1109c 414 $text =~ tr/\n\r / /s;
47c75494 415
b3e1109c
TC
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;
47c75494
TC
437}
438
b3e1109c
TC
439sub summary {
440 my ($self, $article, $limit) = @_;
47c75494 441
b3e1109c
TC
442 $limit ||= $article->summaryLength;
443
e0ed81d7 444 return $self->summarize("BSE::TB::Articles", $article->body, $self->{acts}, $limit);
b3e1109c
TC
445}
446
447# attempts to move the given position forward if it's within a HTML tag,
448# entity or just a word
449sub 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)
470sub _make_html {
471 return unescape_html($_[0]);
472}
473
474sub _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 }
47c75494 489 }
b3e1109c
TC
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 **";;
47c75494 496 }
b3e1109c
TC
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 }
47c75494
TC
507 }
508 else {
b3e1109c 509 $id = $what;
47c75494 510 }
b3e1109c
TC
511
512 $embed = $articles->getByPkey($id)
513 or return "** Cannot find article $id to be embedded **";;
47c75494 514 }
b3e1109c
TC
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} **";
47c75494 527 }
b3e1109c
TC
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 );
47c75494 537 }
47c75494 538
b3e1109c
TC
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;
47c75494 547
b3e1109c
TC
548 return $result;
549}
41358dcc 550
b3e1109c
TC
551sub formatter_class {
552 require BSE::Formatter::Article;
553 return 'BSE::Formatter::Article'
554}
8aee8e95 555
b3e1109c
TC
556# replace markup, insert img tags
557sub 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 );
41358dcc 569
b3e1109c
TC
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};
41358dcc 579
b3e1109c 580 return substr($body, 6) if $body =~ /^<html>/i;
771ab646 581
b3e1109c 582 my $formatter_class = $self->formatter_class;
daee3409 583
b3e1109c
TC
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);
daee3409 592
b3e1109c 593 $body = $formatter->format($body);
9366cd70 594
b3e1109c 595 my $xhtml = $self->{cfg}->entry('basic', 'xhtml', 1);
9366cd70 596
b3e1109c
TC
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';
41358dcc 606
b3e1109c
TC
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;
41358dcc 613 }
b3e1109c
TC
614 elsif ($len > 800) {
615 $len -= 200;
41358dcc 616 }
41358dcc 617
b3e1109c
TC
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
9f5d6afa 641 }
b3e1109c
TC
642
643 return make_entities($body);
9f5d6afa
TC
644}
645
b3e1109c
TC
646sub embed {
647 my ($self, $article, $articles, $template) = @_;
41358dcc 648
b3e1109c
TC
649 if (defined $template && $template =~ /\$/) {
650 $template =~ s/\$/$article->{template}/;
6e3d2da5
TC
651 }
652 else {
b3e1109c
TC
653 $template = $article->{template}
654 unless defined($template) && $template =~ /\S/;
6e3d2da5 655 }
41358dcc 656
b3e1109c
TC
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;
41358dcc 665 }
b3e1109c
TC
666 return $self->generate_low($html, $article, $articles, 1);
667}
41358dcc 668
b3e1109c 669=item vembed(article)
41358dcc 670
b3e1109c
TC
671=item vembed(article, template)
672
673Embed the specified article using either the article template or the
674specified template.
675
676=back
677
678=head1 GENERATOR TAGS
679
680=over
681
682=cut
683
684
685sub vembed {
686 my ($self, $article, $template) = @_;
687
e0ed81d7 688 return $self->embed($article, "BSE::TB::Articles", $template);
b3e1109c
TC
689}
690
691sub 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");
41358dcc
TC
701 }
702 }
b3e1109c
TC
703 @ids = grep /^\d+$|^-1$/, @ids;
704 if (@ids == 1) {
705 $state->{parentid} = $ids[0];
706 }
e0ed81d7 707 $self->_do_filter($filter, map BSE::TB::Articles->listedChildren($_), @ids);
b3e1109c 708}
41358dcc 709
b3e1109c
TC
710my $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) {
e0ed81d7 722 my $cols_expr = '(' . join('|', BSE::TB::Article->columns) . ')';
b3e1109c
TC
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;
41358dcc
TC
739 }
740 else {
b3e1109c 741 return;
41358dcc 742 }
41358dcc 743 }
41358dcc
TC
744}
745
b3e1109c
TC
746sub _do_filter {
747 my ($self, $filter, @articles) = @_;
d38f3b10 748
b3e1109c
TC
749 $filter
750 or return @articles;
8aee8e95 751
b3e1109c
TC
752 return grep $filter->($_), @articles;
753}
d38f3b10 754
b3e1109c
TC
755sub iter_all_kids_of {
756 my ($self, $state, $args, $acts, $name, $templater) = @_;
5e104f12 757
b3e1109c 758 my $filter = $self->_get_filter(\$args);
00dd8d82 759
b3e1109c
TC
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
e0ed81d7 770 $self->_do_filter($filter, map BSE::TB::Articles->all_visible_kids($_), @ids);
8aee8e95 771}
41358dcc 772
b3e1109c
TC
773sub iter_inlines {
774 my ($self, $state, $args, $acts, $name, $templater) = @_;
47e2aec7 775
b3e1109c
TC
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
e0ed81d7 788 $self->_do_filter($filter, map BSE::TB::Articles->getByPkey($_), @ids);
47e2aec7
TC
789}
790
b3e1109c
TC
791sub iter_gimages {
792 my ($self, $args) = @_;
daee3409
TC
793
794 unless ($self->{gimages}) {
47e2aec7 795 $self->_init_gimages;
daee3409
TC
796 }
797
b3e1109c
TC
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 }
daee3409
TC
805}
806
b3e1109c
TC
807sub iter_gfiles {
808 my ($self, $args) = @_;
9366cd70
TC
809
810 unless ($self->{gfiles}) {
e0ed81d7 811 my @gfiles = BSE::TB::Articles->global_files;
9366cd70
TC
812 my %gfiles = map { $_->{name} => $_ } @gfiles;
813 $self->{gfiles} = \%gfiles;
814 }
815
b3e1109c
TC
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;
195977cd
TC
829 }
830 else {
b3e1109c 831 return @gfiles;
195977cd 832 }
74b21f6d
TC
833}
834
b3e1109c 835sub admin_tags {
cf23a1c7
TC
836 my ($self) = @_;
837
b3e1109c 838 $self->{admin} or return;
cf23a1c7 839
b3e1109c 840 return BSE::Util::Tags->secure($self->{request});
cf23a1c7
TC
841}
842
b3e1109c
TC
843sub _static_images {
844 my ($self) = @_;
41358dcc 845
b3e1109c
TC
846 my $static = $self->{cfg}->entry('basic', 'static_thumbnails', 1);
847 $self->{admin} and $static = 0;
848 $self->{dynamic} and $static = 0;
41358dcc 849
b3e1109c
TC
850 return $static;
851}
41358dcc 852
b3e1109c
TC
853# implements popimage and gpopimage
854sub do_popimage_low {
855 my ($self, $im, $class) = @_;
41358dcc 856
b3e1109c
TC
857 return $im->popimage
858 (
859 cfg => $self->cfg,
860 class => $class,
861 static => $self->_static_images,
862 );
8aee8e95 863
b3e1109c 864}
8aee8e95 865
b3e1109c
TC
866sub do_gpopimage {
867 my ($self, $image_id, $class) = @_;
8aee8e95 868
b3e1109c
TC
869 my $im = $self->get_gimage($image_id)
870 or return "* Unknown global image '$image_id' *";
8aee8e95 871
b3e1109c
TC
872 return $self->do_popimage_low($im, $class);
873}
8aee8e95 874
b3e1109c
TC
875sub _sthumbimage_low {
876 my ($self, $geometry, $im, $field) = @_;
957a90ca 877
b3e1109c
TC
878 return $self->_thumbimage_low($geometry, $im, $field, $self->{cfg}, $self->_static_images);
879}
957a90ca 880
b3e1109c
TC
881sub tag_gthumbimage {
882 my ($self, $rcurrent, $args, $acts, $name, $templater) = @_;
957a90ca 883
b3e1109c 884 my ($geometry_id, $id, $field) = DevHelp::Tags->get_parms($args, $acts, $templater);
957a90ca 885
b3e1109c
TC
886 return $self->do_gthumbimage($geometry_id, $id, $field, $$rcurrent);
887}
957a90ca 888
b3e1109c
TC
889sub _find_image {
890 my ($self, $acts, $templater, $article_id, $image_tags, $msg) = @_;
957a90ca 891
b3e1109c
TC
892 my $article;
893 if ($article_id =~ /^\d+$/) {
e0ed81d7
AO
894 require BSE::TB::Articles;
895 $article = BSE::TB::Articles->getByPkey($article_id);
b3e1109c
TC
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");
e0ed81d7 903 $article = BSE::TB::Articles->getByPkey($id);
b3e1109c
TC
904 unless ($article) {
905 $$msg = "* article $article_id/$id not found *";
906 return;
907 }
908 }
909 else {
e0ed81d7 910 ($article) = BSE::TB::Articles->getBy(linkAlias => $article_id);
b3e1109c
TC
911 unless ($article) {
912 $$msg = "* no article $article_id found *";
913 return;
914 }
915 }
916 $article
917 or return;
957a90ca 918
b3e1109c
TC
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 }
957a90ca 942
b3e1109c
TC
943 return $im;
944}
957a90ca 945
b3e1109c
TC
946sub tag_sthumbimage {
947 my ($self, $args, $acts, $name, $templater) = @_;
957a90ca 948
b3e1109c 949 my ($article_id, $geometry, $image_tags, $field) = split ' ', $args;
957a90ca 950
b3e1109c
TC
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}
957a90ca 957
b3e1109c
TC
958sub tag_simage {
959 my ($self, $args, $acts, $name, $templater) = @_;
957a90ca 960
b3e1109c 961 my ($article_id, $image_tags, $field, $rest) = split ' ', $args, 4;
957a90ca 962
b3e1109c
TC
963 my $msg;
964 my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
965 or return $msg;
957a90ca 966
b3e1109c
TC
967 return $self->_format_image($im, $field, $rest);
968}
957a90ca 969
b3e1109c 970=item iterator vimages I<articles> I<filter>
957a90ca 971
b3e1109c 972=item iterator vimages I<articles>
957a90ca 973
b3e1109c 974Iterates over the images belonging to the articles specified.
957a90ca 975
b3e1109c 976I<articles> can be any of:
957a90ca 977
b3e1109c 978=over
957a90ca 979
b3e1109c 980=item *
957a90ca 981
b3e1109c 982article - the current article
957a90ca 983
b3e1109c 984=item *
957a90ca 985
b3e1109c
TC
986children - all visible children (including stepkids) of the current
987article
957a90ca 988
b3e1109c 989=item *
957a90ca 990
b3e1109c 991parent - the parent of the current article
957a90ca 992
b3e1109c 993=item *
957a90ca 994
b3e1109c 995I<number> - a numeric article id, such as C<10>.
957a90ca 996
b3e1109c 997=item *
957a90ca 998
b3e1109c 999alias(I<alias>) - a link alias of an article
957a90ca 1000
b3e1109c 1001=item *
957a90ca 1002
b3e1109c
TC
1003childrenof(I<articles>) - an articles that are children of
1004I<articles>. I<articles> can be any normal article spec, so
1005C<childrenof(childrenof(-1))> is valid.
957a90ca 1006
b3e1109c 1007=item *
957a90ca 1008
b3e1109c 1009I<tagname> - a tag name referring to an article.
957a90ca 1010
b3e1109c 1011=back
957a90ca 1012
b3e1109c 1013I<articles> has [] replacement done before parsing.
957a90ca 1014
b3e1109c 1015I<filter> can be missing, or either of:
957a90ca 1016
b3e1109c 1017=over
957a90ca 1018
b3e1109c 1019=item *
957a90ca 1020
b3e1109c
TC
1021named /I<regexp>/ - images with names matching the given regular
1022expression
957a90ca 1023
b3e1109c 1024=item *
957a90ca 1025
b3e1109c 1026numbered I<number> - images with the given index.
957a90ca 1027
b3e1109c 1028=back
957a90ca 1029
b3e1109c 1030Items for this iterator are vimage and vthumbimage.
957a90ca 1031
b3e1109c 1032=cut
957a90ca 1033
b3e1109c
TC
1034sub iter_vimages {
1035 my ($self, $article, $args, $acts, $name, $templater) = @_;
957a90ca 1036
b3e1109c
TC
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 }
957a90ca 1064
b3e1109c
TC
1065 return @images;
1066}
957a90ca 1067
b3e1109c 1068=item vimage field
957a90ca 1069
b3e1109c 1070=item vimage
957a90ca 1071
b3e1109c 1072Retrieve the given field from the current vimage, or display the image.
957a90ca 1073
b3e1109c 1074=cut
957a90ca 1075
b3e1109c
TC
1076sub tag_vimage {
1077 my ($self, $rvimage, $args) = @_;
957a90ca 1078
b3e1109c 1079 $$rvimage or return '** no current vimage **';
957a90ca 1080
b3e1109c 1081 my ($field, $rest) = split ' ', $args, 2;
957a90ca 1082
b3e1109c
TC
1083 return $self->_format_image($$rvimage, $field, $rest);
1084}
957a90ca 1085
b3e1109c 1086=item vthumbimage geometry field
957a90ca 1087
b3e1109c 1088=item vthumbimage geometry
957a90ca 1089
b3e1109c
TC
1090Retrieve the given field from the thumbnail of the current vimage or
1091display the thumbnail.
957a90ca 1092
b3e1109c 1093=cut
957a90ca 1094
b3e1109c
TC
1095sub tag_vthumbimage {
1096 my ($self, $rvimage, $args) = @_;
957a90ca 1097
b3e1109c
TC
1098 $$rvimage or return '** no current vimage **';
1099 my ($geo, $field) = split ' ', $args;
957a90ca 1100
b3e1109c
TC
1101 return $self->_sthumbimage_low($geo, $$rvimage, $field);
1102}
957a90ca 1103
b3e1109c
TC
1104sub _find_articles {
1105 my ($self, $article_id, $article, $acts, $name, $templater) = @_;
957a90ca 1106
b3e1109c 1107 if ($article_id =~ /^\d+$/) {
e0ed81d7 1108 my $result = BSE::TB::Articles->getByPkey($article_id);
b3e1109c
TC
1109 $result or print STDERR "** Unknown article id $article_id **\n";
1110 return $result ? $result : ();
1111 }
1112 elsif ($article_id =~ /^alias\((\w+)\)$/) {
e0ed81d7 1113 my $result = BSE::TB::Articles->getBy(linkAlias => $1);
b3e1109c
TC
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') {
e0ed81d7 1120 return BSE::TB::Articles->all_visible_kids(-1);
b3e1109c
TC
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+$/) {
e0ed81d7 1131 return BSE::TB::Articles->getByPkey($id);
b3e1109c
TC
1132 }
1133 }
1134 print STDERR "** Unknown article identifier $article_id **\n";
d2730773 1135
b3e1109c
TC
1136 return;
1137}
d2730773 1138
b3e1109c
TC
1139sub baseActs {
1140 my ($self, $articles, $acts, $article, $embedded) = @_;
d2730773 1141
b3e1109c
TC
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;
d2730773 1151
b3e1109c
TC
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 }
d2730773 1159
b3e1109c
TC
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,
d2730773 1172
b3e1109c
TC
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} },
d2730773 1186
b3e1109c
TC
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 },
d2730773 1223
b3e1109c
TC
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 },
d2730773 1251
b3e1109c
TC
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];
d2730773 1274
b3e1109c
TC
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";
d2730773 1334
b3e1109c
TC
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 }
d2730773 1346
b3e1109c
TC
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;
d2730773 1354
b3e1109c
TC
1355 my $file = $self->get_gfile($name)
1356 or return '';
d2730773 1357
b3e1109c
TC
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}
d2730773 1369
d325876a
TC
1370sub _highlight_partial {
1371 my ($self) = @_;
1372
1373 $self->{cfg}->entryBool('search', 'highlight_partial', 1);
1374}
1375
b3e1109c 1376sub find_terms {
d325876a
TC
1377 my ($self, $body, $case_sensitive, $terms) = @_;
1378
1379 my $eow = $self->_highlight_partial ? "" : qr/\b/;
b3e1109c
TC
1380 # locate the terms
1381 my @found;
1382 if ($case_sensitive) {
1383 for my $term (@$terms) {
d325876a 1384 if ($$body =~ /^(.*?)\b\Q$term\E$eow/s) {
b3e1109c
TC
1385 push(@found, [ length($1), $term ]);
1386 }
1387 }
1388 }
1389 else {
1390 for my $term (@$terms) {
d325876a 1391 if ($$body =~ /^(.*?)\b\Q$term\E$eow/is) {
b3e1109c
TC
1392 push(@found, [ length($1), $term ]);
1393 }
1394 }
1395 }
d2730773 1396
b3e1109c
TC
1397 return @found;
1398}
d2730773 1399
b3e1109c
TC
1400# this takes the same inputs as _make_table(), but eliminates any
1401# markup instead
1402sub _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}
d2730773 1411
b3e1109c
TC
1412# produce a nice excerpt for a found article
1413sub excerpt {
1414 my ($self, $article, $found, $case_sensitive, $terms, $type, $body) = @_;
d2730773 1415
b3e1109c
TC
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;
e0ed81d7 1422 $self->remove_block('BSE::TB::Articles', [], \$body, \@files);
b3e1109c
TC
1423 1 while $body =~ s/[bi]\[([^\]\[]+)\]/$1/g;
1424 }
1425
1426 $body = escape_html($body);
d2730773 1427
b3e1109c 1428 $type ||= 'body';
d2730773 1429
d325876a 1430 my @found = $self->find_terms(\$body, $case_sensitive, $terms);
d2730773 1431
b3e1109c
TC
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};
d325876a 1443 if ($self->_highlight_partial) {
b3e1109c
TC
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 }
d2730773 1449
b3e1109c
TC
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 }
d2730773 1462
b3e1109c
TC
1463 # only the first 5
1464 splice(@found, 5,-1) if @found > 5;
1465 my $itemSize = $excerptSize / @found;
d2730773 1466
b3e1109c
TC
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 }
d2730773 1477
b3e1109c 1478 my $highlight_prefix =
947d7c09 1479 $cfg->entry('search highlight', "${type}_prefix", $cfg->entry('search highlight', "prefix", "<b>"));
b3e1109c 1480 my $highlight_suffix =
947d7c09 1481 $cfg->entry('search highlight', "${type}_suffix", $cfg->entry('search highlight', "suffix", "</b>"));
b3e1109c
TC
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;
d2730773 1504
b3e1109c
TC
1505 return $result;
1506}
d2730773 1507
b3e1109c
TC
1508sub visible {
1509 return 1;
1510}
d2730773 1511
d2730773 1512
b3e1109c
TC
1513# make whatever text $body points at safe for summarizing by removing most
1514# block level formatting
1515sub remove_block {
1516 my ($self, $articles, $acts, $body, $files) = @_;
d2730773 1517
b3e1109c 1518 my $formatter_class = $self->formatter_class;
d2730773 1519
b3e1109c 1520 $files ||= [];
d2730773 1521
b3e1109c
TC
1522 my $formatter = $formatter_class->new(gen => $self,
1523 acts => $acts,
1524 article => $articles,
1525 articles => $articles,
1526 files => $files);
d2730773 1527
b3e1109c
TC
1528 $$body = $formatter->remove_format($$body);
1529}
d2730773 1530
b3e1109c
TC
1531sub _init_gimages {
1532 my ($self) = @_;
d2730773 1533
b3e1109c
TC
1534 my @gimages = $self->site->images;
1535 $self->{gimages} = { map { $_->{name} => $_ } @gimages };
1536 $self->{gimages_a} = \@gimages;
1537}
d2730773 1538
b3e1109c
TC
1539sub get_gimage {
1540 my ($self, $name) = @_;
d2730773 1541
b3e1109c
TC
1542 unless ($self->{gimages}) {
1543 $self->_init_gimages;
1544 }
d2730773 1545
b3e1109c
TC
1546 return $self->{gimages}{$name};
1547}
d2730773 1548
b3e1109c
TC
1549sub get_gfile {
1550 my ($self, $name) = @_;
d2730773 1551
b3e1109c 1552 unless ($self->{gfiles}) {
e0ed81d7 1553 my @gfiles = BSE::TB::Articles->global_files;
b3e1109c
TC
1554 my %gfiles = map { $_->{name} => $_ } @gfiles;
1555 $self->{gfiles} = \%gfiles;
1556 }
d2730773 1557
b3e1109c
TC
1558 return $self->{gfiles}{$name};
1559}
d2730773 1560
b3e1109c
TC
1561# note: this is called by BSE::Formatter::thumbimage(), update that if
1562# this is changed
1563sub do_gthumbimage {
1564 my ($self, $geo_id, $image_id, $field, $current) = @_;
41358dcc 1565
b3e1109c
TC
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 **';
73b3a7aa 1575
b3e1109c
TC
1576 return $self->_sthumbimage_low($geo_id, $im, $field);
1577}
73b3a7aa 1578
b3e1109c
TC
1579sub get_real_article {
1580 my ($self, $article) = @_;
73b3a7aa 1581
b3e1109c
TC
1582 return $article;
1583}
73b3a7aa 1584
b3e1109c
TC
1585sub localize {
1586 my ($self) = @_;
73b3a7aa 1587
b3e1109c
TC
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}
73b3a7aa 1598
b3e1109c
TC
1599sub unlocalize {
1600 my ($self) = @_;
73b3a7aa 1601
b3e1109c
TC
1602 $self->{vars} = pop @{$self->{varstack}};
1603}
73b3a7aa 1604
b3e1109c 16051;
73b3a7aa 1606
b3e1109c 1607__END__
73b3a7aa
TC
1608
1609=back
1610
41358dcc
TC
1611=head1 BUGS
1612
1613Needs more documentation.
1614
1615=cut