fix generator.vembed()
[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
63dc4fe2 316our $VERSION = "1.027";
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
a85fb6e0 474sub _embed_tag {
b3e1109c
TC
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 515
a85fb6e0
TC
516 return $self->_embed_low($embed, $articles, $template, $maxdepth);
517}
518
519sub _embed_low {
520 my ($self, $embed, $articles, $template, $maxdepth) = @_;
521
b3e1109c
TC
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} **";
47c75494 533 }
b3e1109c
TC
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 );
47c75494 543 }
47c75494 544
b3e1109c
TC
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;
47c75494 553
b3e1109c
TC
554 return $result;
555}
41358dcc 556
b3e1109c
TC
557sub formatter_class {
558 require BSE::Formatter::Article;
559 return 'BSE::Formatter::Article'
560}
8aee8e95 561
b3e1109c
TC
562# replace markup, insert img tags
563sub 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 );
41358dcc 575
b3e1109c
TC
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};
41358dcc 585
b3e1109c 586 return substr($body, 6) if $body =~ /^<html>/i;
771ab646 587
b3e1109c 588 my $formatter_class = $self->formatter_class;
daee3409 589
b3e1109c
TC
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);
daee3409 598
b3e1109c 599 $body = $formatter->format($body);
9366cd70 600
b3e1109c 601 my $xhtml = $self->{cfg}->entry('basic', 'xhtml', 1);
9366cd70 602
b3e1109c
TC
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';
41358dcc 612
b3e1109c
TC
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;
41358dcc 619 }
b3e1109c
TC
620 elsif ($len > 800) {
621 $len -= 200;
41358dcc 622 }
41358dcc 623
b3e1109c
TC
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
9f5d6afa 647 }
b3e1109c
TC
648
649 return make_entities($body);
9f5d6afa
TC
650}
651
b3e1109c
TC
652sub embed {
653 my ($self, $article, $articles, $template) = @_;
41358dcc 654
b3e1109c
TC
655 if (defined $template && $template =~ /\$/) {
656 $template =~ s/\$/$article->{template}/;
6e3d2da5
TC
657 }
658 else {
b3e1109c
TC
659 $template = $article->{template}
660 unless defined($template) && $template =~ /\S/;
6e3d2da5 661 }
41358dcc 662
b3e1109c
TC
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;
41358dcc 671 }
b3e1109c
TC
672 return $self->generate_low($html, $article, $articles, 1);
673}
41358dcc 674
b3e1109c 675=item vembed(article)
41358dcc 676
b3e1109c
TC
677=item vembed(article, template)
678
679Embed the specified article using either the article template or the
680specified template.
681
682=back
683
684=head1 GENERATOR TAGS
685
686=over
687
688=cut
689
690
691sub vembed {
63dc4fe2 692 my ($self, $article, $template, $maxdepth) = @_;
b3e1109c 693
63dc4fe2
TC
694 $maxdepth = $self->{maxdepth}
695 if !$maxdepth || $maxdepth > $self->{maxdepth};
696
697 return $self->_embed_low($article, "BSE::TB::Articles", $template, $maxdepth);
b3e1109c
TC
698}
699
700sub 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");
41358dcc
TC
710 }
711 }
b3e1109c
TC
712 @ids = grep /^\d+$|^-1$/, @ids;
713 if (@ids == 1) {
714 $state->{parentid} = $ids[0];
715 }
e0ed81d7 716 $self->_do_filter($filter, map BSE::TB::Articles->listedChildren($_), @ids);
b3e1109c 717}
41358dcc 718
b3e1109c
TC
719my $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) {
e0ed81d7 731 my $cols_expr = '(' . join('|', BSE::TB::Article->columns) . ')';
b3e1109c
TC
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;
41358dcc
TC
748 }
749 else {
b3e1109c 750 return;
41358dcc 751 }
41358dcc 752 }
41358dcc
TC
753}
754
b3e1109c
TC
755sub _do_filter {
756 my ($self, $filter, @articles) = @_;
d38f3b10 757
b3e1109c
TC
758 $filter
759 or return @articles;
8aee8e95 760
b3e1109c
TC
761 return grep $filter->($_), @articles;
762}
d38f3b10 763
b3e1109c
TC
764sub iter_all_kids_of {
765 my ($self, $state, $args, $acts, $name, $templater) = @_;
5e104f12 766
b3e1109c 767 my $filter = $self->_get_filter(\$args);
00dd8d82 768
b3e1109c
TC
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
e0ed81d7 779 $self->_do_filter($filter, map BSE::TB::Articles->all_visible_kids($_), @ids);
8aee8e95 780}
41358dcc 781
b3e1109c
TC
782sub iter_inlines {
783 my ($self, $state, $args, $acts, $name, $templater) = @_;
47e2aec7 784
b3e1109c
TC
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
e0ed81d7 797 $self->_do_filter($filter, map BSE::TB::Articles->getByPkey($_), @ids);
47e2aec7
TC
798}
799
b3e1109c
TC
800sub iter_gimages {
801 my ($self, $args) = @_;
daee3409
TC
802
803 unless ($self->{gimages}) {
47e2aec7 804 $self->_init_gimages;
daee3409
TC
805 }
806
b3e1109c
TC
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 }
daee3409
TC
814}
815
b3e1109c
TC
816sub iter_gfiles {
817 my ($self, $args) = @_;
9366cd70
TC
818
819 unless ($self->{gfiles}) {
e0ed81d7 820 my @gfiles = BSE::TB::Articles->global_files;
9366cd70
TC
821 my %gfiles = map { $_->{name} => $_ } @gfiles;
822 $self->{gfiles} = \%gfiles;
823 }
824
b3e1109c
TC
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;
195977cd
TC
838 }
839 else {
b3e1109c 840 return @gfiles;
195977cd 841 }
74b21f6d
TC
842}
843
b3e1109c 844sub admin_tags {
cf23a1c7
TC
845 my ($self) = @_;
846
b3e1109c 847 $self->{admin} or return;
cf23a1c7 848
b3e1109c 849 return BSE::Util::Tags->secure($self->{request});
cf23a1c7
TC
850}
851
b3e1109c
TC
852sub _static_images {
853 my ($self) = @_;
41358dcc 854
b3e1109c
TC
855 my $static = $self->{cfg}->entry('basic', 'static_thumbnails', 1);
856 $self->{admin} and $static = 0;
857 $self->{dynamic} and $static = 0;
41358dcc 858
b3e1109c
TC
859 return $static;
860}
41358dcc 861
b3e1109c
TC
862# implements popimage and gpopimage
863sub do_popimage_low {
864 my ($self, $im, $class) = @_;
41358dcc 865
b3e1109c
TC
866 return $im->popimage
867 (
868 cfg => $self->cfg,
869 class => $class,
870 static => $self->_static_images,
871 );
8aee8e95 872
b3e1109c 873}
8aee8e95 874
b3e1109c
TC
875sub do_gpopimage {
876 my ($self, $image_id, $class) = @_;
8aee8e95 877
b3e1109c
TC
878 my $im = $self->get_gimage($image_id)
879 or return "* Unknown global image '$image_id' *";
8aee8e95 880
b3e1109c
TC
881 return $self->do_popimage_low($im, $class);
882}
8aee8e95 883
b3e1109c
TC
884sub _sthumbimage_low {
885 my ($self, $geometry, $im, $field) = @_;
957a90ca 886
b3e1109c
TC
887 return $self->_thumbimage_low($geometry, $im, $field, $self->{cfg}, $self->_static_images);
888}
957a90ca 889
b3e1109c
TC
890sub tag_gthumbimage {
891 my ($self, $rcurrent, $args, $acts, $name, $templater) = @_;
957a90ca 892
b3e1109c 893 my ($geometry_id, $id, $field) = DevHelp::Tags->get_parms($args, $acts, $templater);
957a90ca 894
b3e1109c
TC
895 return $self->do_gthumbimage($geometry_id, $id, $field, $$rcurrent);
896}
957a90ca 897
b3e1109c
TC
898sub _find_image {
899 my ($self, $acts, $templater, $article_id, $image_tags, $msg) = @_;
957a90ca 900
b3e1109c
TC
901 my $article;
902 if ($article_id =~ /^\d+$/) {
e0ed81d7
AO
903 require BSE::TB::Articles;
904 $article = BSE::TB::Articles->getByPkey($article_id);
b3e1109c
TC
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");
e0ed81d7 912 $article = BSE::TB::Articles->getByPkey($id);
b3e1109c
TC
913 unless ($article) {
914 $$msg = "* article $article_id/$id not found *";
915 return;
916 }
917 }
918 else {
e0ed81d7 919 ($article) = BSE::TB::Articles->getBy(linkAlias => $article_id);
b3e1109c
TC
920 unless ($article) {
921 $$msg = "* no article $article_id found *";
922 return;
923 }
924 }
925 $article
926 or return;
957a90ca 927
b3e1109c
TC
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 }
957a90ca 951
b3e1109c
TC
952 return $im;
953}
957a90ca 954
b3e1109c
TC
955sub tag_sthumbimage {
956 my ($self, $args, $acts, $name, $templater) = @_;
957a90ca 957
b3e1109c 958 my ($article_id, $geometry, $image_tags, $field) = split ' ', $args;
957a90ca 959
b3e1109c
TC
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}
957a90ca 966
b3e1109c
TC
967sub tag_simage {
968 my ($self, $args, $acts, $name, $templater) = @_;
957a90ca 969
b3e1109c 970 my ($article_id, $image_tags, $field, $rest) = split ' ', $args, 4;
957a90ca 971
b3e1109c
TC
972 my $msg;
973 my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
974 or return $msg;
957a90ca 975
b3e1109c
TC
976 return $self->_format_image($im, $field, $rest);
977}
957a90ca 978
b3e1109c 979=item iterator vimages I<articles> I<filter>
957a90ca 980
b3e1109c 981=item iterator vimages I<articles>
957a90ca 982
b3e1109c 983Iterates over the images belonging to the articles specified.
957a90ca 984
b3e1109c 985I<articles> can be any of:
957a90ca 986
b3e1109c 987=over
957a90ca 988
b3e1109c 989=item *
957a90ca 990
b3e1109c 991article - the current article
957a90ca 992
b3e1109c 993=item *
957a90ca 994
b3e1109c
TC
995children - all visible children (including stepkids) of the current
996article
957a90ca 997
b3e1109c 998=item *
957a90ca 999
b3e1109c 1000parent - the parent of the current article
957a90ca 1001
b3e1109c 1002=item *
957a90ca 1003
b3e1109c 1004I<number> - a numeric article id, such as C<10>.
957a90ca 1005
b3e1109c 1006=item *
957a90ca 1007
b3e1109c 1008alias(I<alias>) - a link alias of an article
957a90ca 1009
b3e1109c 1010=item *
957a90ca 1011
b3e1109c
TC
1012childrenof(I<articles>) - an articles that are children of
1013I<articles>. I<articles> can be any normal article spec, so
1014C<childrenof(childrenof(-1))> is valid.
957a90ca 1015
b3e1109c 1016=item *
957a90ca 1017
b3e1109c 1018I<tagname> - a tag name referring to an article.
957a90ca 1019
b3e1109c 1020=back
957a90ca 1021
b3e1109c 1022I<articles> has [] replacement done before parsing.
957a90ca 1023
b3e1109c 1024I<filter> can be missing, or either of:
957a90ca 1025
b3e1109c 1026=over
957a90ca 1027
b3e1109c 1028=item *
957a90ca 1029
b3e1109c
TC
1030named /I<regexp>/ - images with names matching the given regular
1031expression
957a90ca 1032
b3e1109c 1033=item *
957a90ca 1034
b3e1109c 1035numbered I<number> - images with the given index.
957a90ca 1036
b3e1109c 1037=back
957a90ca 1038
b3e1109c 1039Items for this iterator are vimage and vthumbimage.
957a90ca 1040
b3e1109c 1041=cut
957a90ca 1042
b3e1109c
TC
1043sub iter_vimages {
1044 my ($self, $article, $args, $acts, $name, $templater) = @_;
957a90ca 1045
b3e1109c
TC
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 }
957a90ca 1073
b3e1109c
TC
1074 return @images;
1075}
957a90ca 1076
b3e1109c 1077=item vimage field
957a90ca 1078
b3e1109c 1079=item vimage
957a90ca 1080
b3e1109c 1081Retrieve the given field from the current vimage, or display the image.
957a90ca 1082
b3e1109c 1083=cut
957a90ca 1084
b3e1109c
TC
1085sub tag_vimage {
1086 my ($self, $rvimage, $args) = @_;
957a90ca 1087
b3e1109c 1088 $$rvimage or return '** no current vimage **';
957a90ca 1089
b3e1109c 1090 my ($field, $rest) = split ' ', $args, 2;
957a90ca 1091
b3e1109c
TC
1092 return $self->_format_image($$rvimage, $field, $rest);
1093}
957a90ca 1094
b3e1109c 1095=item vthumbimage geometry field
957a90ca 1096
b3e1109c 1097=item vthumbimage geometry
957a90ca 1098
b3e1109c
TC
1099Retrieve the given field from the thumbnail of the current vimage or
1100display the thumbnail.
957a90ca 1101
b3e1109c 1102=cut
957a90ca 1103
b3e1109c
TC
1104sub tag_vthumbimage {
1105 my ($self, $rvimage, $args) = @_;
957a90ca 1106
b3e1109c
TC
1107 $$rvimage or return '** no current vimage **';
1108 my ($geo, $field) = split ' ', $args;
957a90ca 1109
b3e1109c
TC
1110 return $self->_sthumbimage_low($geo, $$rvimage, $field);
1111}
957a90ca 1112
b3e1109c
TC
1113sub _find_articles {
1114 my ($self, $article_id, $article, $acts, $name, $templater) = @_;
957a90ca 1115
b3e1109c 1116 if ($article_id =~ /^\d+$/) {
e0ed81d7 1117 my $result = BSE::TB::Articles->getByPkey($article_id);
b3e1109c
TC
1118 $result or print STDERR "** Unknown article id $article_id **\n";
1119 return $result ? $result : ();
1120 }
1121 elsif ($article_id =~ /^alias\((\w+)\)$/) {
e0ed81d7 1122 my $result = BSE::TB::Articles->getBy(linkAlias => $1);
b3e1109c
TC
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') {
e0ed81d7 1129 return BSE::TB::Articles->all_visible_kids(-1);
b3e1109c
TC
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+$/) {
e0ed81d7 1140 return BSE::TB::Articles->getByPkey($id);
b3e1109c
TC
1141 }
1142 }
1143 print STDERR "** Unknown article identifier $article_id **\n";
d2730773 1144
b3e1109c
TC
1145 return;
1146}
d2730773 1147
b3e1109c
TC
1148sub baseActs {
1149 my ($self, $articles, $acts, $article, $embedded) = @_;
d2730773 1150
b3e1109c
TC
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;
d2730773 1160
b3e1109c
TC
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 }
d2730773 1168
b3e1109c
TC
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,
d2730773 1181
b3e1109c
TC
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+/;
a85fb6e0 1192 return $self->_embed_tag($acts, $articles, $what, $template, $maxdepth, $templater);
b3e1109c
TC
1193 },
1194 ifCanEmbed=> sub { $self->{depth} <= $self->{maxdepth} },
d2730773 1195
b3e1109c
TC
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 },
d2730773 1232
b3e1109c
TC
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 },
d2730773 1260
b3e1109c
TC
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];
d2730773 1283
b3e1109c
TC
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";
d2730773 1343
b3e1109c
TC
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 }
d2730773 1355
b3e1109c
TC
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;
d2730773 1363
b3e1109c
TC
1364 my $file = $self->get_gfile($name)
1365 or return '';
d2730773 1366
b3e1109c
TC
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}
d2730773 1378
d325876a
TC
1379sub _highlight_partial {
1380 my ($self) = @_;
1381
1382 $self->{cfg}->entryBool('search', 'highlight_partial', 1);
1383}
1384
b3e1109c 1385sub find_terms {
d325876a
TC
1386 my ($self, $body, $case_sensitive, $terms) = @_;
1387
1388 my $eow = $self->_highlight_partial ? "" : qr/\b/;
b3e1109c
TC
1389 # locate the terms
1390 my @found;
1391 if ($case_sensitive) {
1392 for my $term (@$terms) {
d325876a 1393 if ($$body =~ /^(.*?)\b\Q$term\E$eow/s) {
b3e1109c
TC
1394 push(@found, [ length($1), $term ]);
1395 }
1396 }
1397 }
1398 else {
1399 for my $term (@$terms) {
d325876a 1400 if ($$body =~ /^(.*?)\b\Q$term\E$eow/is) {
b3e1109c
TC
1401 push(@found, [ length($1), $term ]);
1402 }
1403 }
1404 }
d2730773 1405
b3e1109c
TC
1406 return @found;
1407}
d2730773 1408
b3e1109c
TC
1409# this takes the same inputs as _make_table(), but eliminates any
1410# markup instead
1411sub _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}
d2730773 1420
b3e1109c
TC
1421# produce a nice excerpt for a found article
1422sub excerpt {
1423 my ($self, $article, $found, $case_sensitive, $terms, $type, $body) = @_;
d2730773 1424
b3e1109c
TC
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;
e0ed81d7 1431 $self->remove_block('BSE::TB::Articles', [], \$body, \@files);
b3e1109c
TC
1432 1 while $body =~ s/[bi]\[([^\]\[]+)\]/$1/g;
1433 }
1434
1435 $body = escape_html($body);
d2730773 1436
b3e1109c 1437 $type ||= 'body';
d2730773 1438
d325876a 1439 my @found = $self->find_terms(\$body, $case_sensitive, $terms);
d2730773 1440
b3e1109c
TC
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};
d325876a 1452 if ($self->_highlight_partial) {
b3e1109c
TC
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 }
d2730773 1458
b3e1109c
TC
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 }
d2730773 1471
b3e1109c
TC
1472 # only the first 5
1473 splice(@found, 5,-1) if @found > 5;
1474 my $itemSize = $excerptSize / @found;
d2730773 1475
b3e1109c
TC
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 }
d2730773 1486
b3e1109c 1487 my $highlight_prefix =
947d7c09 1488 $cfg->entry('search highlight', "${type}_prefix", $cfg->entry('search highlight', "prefix", "<b>"));
b3e1109c 1489 my $highlight_suffix =
947d7c09 1490 $cfg->entry('search highlight', "${type}_suffix", $cfg->entry('search highlight', "suffix", "</b>"));
b3e1109c
TC
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;
d2730773 1513
b3e1109c
TC
1514 return $result;
1515}
d2730773 1516
b3e1109c
TC
1517sub visible {
1518 return 1;
1519}
d2730773 1520
d2730773 1521
b3e1109c
TC
1522# make whatever text $body points at safe for summarizing by removing most
1523# block level formatting
1524sub remove_block {
1525 my ($self, $articles, $acts, $body, $files) = @_;
d2730773 1526
b3e1109c 1527 my $formatter_class = $self->formatter_class;
d2730773 1528
b3e1109c 1529 $files ||= [];
d2730773 1530
b3e1109c
TC
1531 my $formatter = $formatter_class->new(gen => $self,
1532 acts => $acts,
1533 article => $articles,
1534 articles => $articles,
1535 files => $files);
d2730773 1536
b3e1109c
TC
1537 $$body = $formatter->remove_format($$body);
1538}
d2730773 1539
b3e1109c
TC
1540sub _init_gimages {
1541 my ($self) = @_;
d2730773 1542
b3e1109c
TC
1543 my @gimages = $self->site->images;
1544 $self->{gimages} = { map { $_->{name} => $_ } @gimages };
1545 $self->{gimages_a} = \@gimages;
1546}
d2730773 1547
b3e1109c
TC
1548sub get_gimage {
1549 my ($self, $name) = @_;
d2730773 1550
b3e1109c
TC
1551 unless ($self->{gimages}) {
1552 $self->_init_gimages;
1553 }
d2730773 1554
b3e1109c
TC
1555 return $self->{gimages}{$name};
1556}
d2730773 1557
b3e1109c
TC
1558sub get_gfile {
1559 my ($self, $name) = @_;
d2730773 1560
b3e1109c 1561 unless ($self->{gfiles}) {
e0ed81d7 1562 my @gfiles = BSE::TB::Articles->global_files;
b3e1109c
TC
1563 my %gfiles = map { $_->{name} => $_ } @gfiles;
1564 $self->{gfiles} = \%gfiles;
1565 }
d2730773 1566
b3e1109c
TC
1567 return $self->{gfiles}{$name};
1568}
d2730773 1569
b3e1109c
TC
1570# note: this is called by BSE::Formatter::thumbimage(), update that if
1571# this is changed
1572sub do_gthumbimage {
1573 my ($self, $geo_id, $image_id, $field, $current) = @_;
41358dcc 1574
b3e1109c
TC
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 **';
73b3a7aa 1584
b3e1109c
TC
1585 return $self->_sthumbimage_low($geo_id, $im, $field);
1586}
73b3a7aa 1587
b3e1109c
TC
1588sub get_real_article {
1589 my ($self, $article) = @_;
73b3a7aa 1590
b3e1109c
TC
1591 return $article;
1592}
73b3a7aa 1593
b3e1109c
TC
1594sub localize {
1595 my ($self) = @_;
73b3a7aa 1596
b3e1109c
TC
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}
73b3a7aa 1607
b3e1109c
TC
1608sub unlocalize {
1609 my ($self) = @_;
73b3a7aa 1610
b3e1109c
TC
1611 $self->{vars} = pop @{$self->{varstack}};
1612}
73b3a7aa 1613
b3e1109c 16141;
73b3a7aa 1615
b3e1109c 1616__END__
73b3a7aa
TC
1617
1618=back
1619
41358dcc
TC
1620=head1 BUGS
1621
1622Needs more documentation.
1623
1624=cut