site/cgi-bin/modules/Generate.pm

   1 package Generate;
   2 use strict;
   3 use Articles;
   4 use Constants qw($IMAGEDIR $LOCAL_FORMAT $BODY_EMBED
   5                  $EMBED_MAX_DEPTH $HAVE_HTML_PARSER);
   6 use DevHelp::Tags;
   7 use BSE::Util::HTML;
   8 use BSE::Util::Tags qw(tag_article);
   9 use BSE::CfgInfo qw(custom_class);
  10 use BSE::Util::Iterate;
  11 use BSE::TB::Site;
  12 use BSE::Variables;
  13 use base 'BSE::ThumbLow';
  14 use base 'BSE::TagFormats';
  15
  16 our $VERSION = "1.008";
  17
  18 my $excerptSize = 300;
  19
  20 sub new {
  21   my ($class, %opts) = @_;
  22   unless ($opts{cfg}) {
  23     require Carp;
  24     Carp->import('confess');
  25     confess("cfg missing on generator->new call");
  26   }
  27   $opts{maxdepth} = $EMBED_MAX_DEPTH unless exists $opts{maxdepth};
  28   $opts{depth} = 0 unless $opts{depth};
  29   $opts{vars} =
  30     {
  31      cfg => $opts{cfg},
  32      bse => BSE::Variables->variables(%opts),
  33     };
  34   my $self = bless \%opts, $class;
  35   $self->set_variable_class(articles => "Articles");
  36
  37   return $self;
  38 }
  39
  40 sub cfg {
  41   $_[0]{cfg};
  42 }
  43
  44 sub set_variable {
  45   my ($self, $name, $value) = @_;
  46
  47   $self->{vars}{$name} = $value;
  48
  49   return 1;
  50 }
  51
  52 sub set_variable_class {
  53   my ($self, $name, $class) = @_;
  54
  55   require Squirrel::Template;
  56   $self->set_variable($name => Squirrel::Template::Expr::WrapClass->new($class));
  57 }
  58
  59 sub variables {
  60   my ($self) = @_;
  61
  62   return $self->{vars};
  63 }
  64
  65 # replace commonly used characters
  66 # like MS dumb-quotes
  67 # unfortunately some browsers^W^Wnetscape don't support the entities yet <sigh>
  68 sub make_entities {
  69   my $text = shift;
  70
  71   $text =~ s/\226/-/g; # "--" looks ugly
  72   $text =~ s/\222/'/g;
  73   $text =~ s/\221/`/g;
  74   $text =~ s/\&#8217;/'/g;
  75
  76   return $text;
  77 }
  78
  79 sub summarize {
  80   my ($self, $articles, $text, $acts, $length) = @_;
  81
  82   # remove any block level formatting
  83   $self->remove_block($articles, $acts, \$text);
  84
  85   $text =~ tr/\n\r / /s;
  86
  87   if (length $text > $length) {
  88     $text = substr($text, 0, $length);
  89     $text =~ s/\s+\S+$//;
  90
  91     # roughly balance [ and ]
  92     my $temp = $text;
  93     1 while $temp =~ s/\s\[[^\]]*\]//; # eliminate matched
  94     my $count = 0;
  95     ++$count while $temp =~ s/\w\[[^\]]*$//; # count unmatched
  96
  97     $text .= ']' x $count;
  98     $text .= '...';
  99   }
 100
 101   # the formatter now adds <p></p> around the text, but we don't
 102   # want that here
 103   my $result = $self->format_body(articles => $articles,
 104                                   text => $text);
 105   $result =~ s!<p>|</p>!!g;
 106
 107   return $result;
 108 }
 109
 110 # attempts to move the given position forward if it's within a HTML tag,
 111 # entity or just a word
 112 sub adjust_for_html {
 113   my ($self, $text, $pos) = @_;
 114
 115   # advance if in a tag
 116   return $pos + length $1
 117     if substr($text, 0, $pos) =~ /<[^<>]*$/
 118       && substr($text, $pos) =~ /^([^<>]*>)/;
 119   return $pos + length $1
 120     if substr($text, 0, $pos) =~ /&[^;&]*$/
 121       && substr($text, $pos) =~ /^([^;&]*;)/;
 122   return $pos + length $1
 123     if $pos <= length $text
 124       && substr($text, $pos-1, 1) =~ /\w$/
 125       && substr($text, $pos) =~ /^(\w+)/;
 126
 127   return $pos;
 128 }
 129
 130 # raw html - this has some limitations
 131 # the input text has already been escaped, so we need to unescape it
 132 # too bad if you want [] in your html (but you can use entities)
 133 sub _make_html {
 134   return unescape_html($_[0]);
 135 }
 136
 137 sub _embed_low {
 138   my ($self, $acts, $articles, $what, $template, $maxdepth, $templater) = @_;
 139
 140   $maxdepth = $self->{maxdepth}
 141     if !$maxdepth || $maxdepth > $self->{maxdepth};
 142   #if ($self->{depth}) {
 143   #  print STDERR "Embed depth $self->{depth}\n";
 144   #}
 145   if ($self->{depth} > $self->{maxdepth}) {
 146     if ($self->{maxdepth} == $EMBED_MAX_DEPTH) {
 147       return "** too many embedding levels **";
 148     }
 149     else {
 150       return '';
 151     }
 152   }
 153
 154   my $embed;
 155   if ($what =~ /^alias:([a-z]\w*)$/) {
 156     my $alias = $1;
 157     ($embed) = $articles->getBy(linkAlias => $alias)
 158       or return "** Cannot find article aliased $alias to be embedded **";;
 159   }
 160   else {
 161     my $id;
 162     if ($what !~ /^\d+$/) {
 163       # not an article id, assume there's an article here we can use
 164       $id = $acts->{$what} && $templater->perform($acts, $what, 'id');
 165       unless ($id && $id =~ /^\d+$/) {
 166         # save it for later
 167         defined $template or $template = "-";
 168         return "<:embed $what $template $maxdepth:>";
 169       }
 170     }
 171     else {
 172       $id = $what;
 173     }
 174
 175     $embed = $articles->getByPkey($id)
 176       or return "** Cannot find article $id to be embedded **";;
 177   }
 178
 179   my $gen = $self;
 180   if (ref($self) ne $embed->{generator}) {
 181     my $genname = $embed->{generator};
 182     $genname =~ s#::#/#g; # broken on MacOS I suppose
 183     $genname .= ".pm";
 184     eval {
 185       require $genname;
 186     };
 187     if ($@) {
 188       print STDERR "Cannot load generator $embed->{generator}: $@\n";
 189       return "** Cannot load generator $embed->{generator} for article $embed->{id} **";
 190     }
 191     my $top = $self->{top} || $embed;
 192     $gen = $embed->{generator}->new
 193       (
 194        admin=>$self->{admin},
 195        admin_links => $self->{admin_links},
 196        cfg=>$self->{cfg},
 197        request=>$self->{request},
 198        top=>$top
 199       );
 200   }
 201
 202   my $olddepth = $gen->{depth};
 203   $gen->{depth} = $self->{depth}+1;
 204   my $oldmaxdepth = $gen->{maxdepth};
 205   $gen->{maxdepth} = $maxdepth;
 206   $template = "" if defined($template) && $template eq "-";
 207   my $result = $gen->embed($embed, $articles, $template);
 208   $gen->{depth} = $olddepth;
 209   $gen->{maxdepth} = $oldmaxdepth;
 210
 211   return $result;
 212 }
 213
 214 sub _body_embed {
 215   my ($self, $acts, $articles, $which, $template, $maxdepth) = @_;
 216
 217   my $text = $self->_embed_low($acts, $articles, $which, $template, $maxdepth);
 218
 219   return $text;
 220 }
 221
 222 sub formatter_class {
 223   require BSE::Formatter::Article;
 224   return 'BSE::Formatter::Article'
 225 }
 226
 227 # replace markup, insert img tags
 228 sub format_body {
 229   my $self = shift;
 230   my (%opts) =
 231     (
 232      abs_urls => 0,
 233      imagepos => 'tr',
 234      auto_images => 1,
 235      images => [],
 236      files => [],
 237      acts => {},
 238      @_
 239     );
 240
 241   my $acts = $opts{acts};
 242   my $articles = $opts{articles};
 243   my $body = $opts{text};
 244   my $imagePos = $opts{imagepos};
 245   my $abs_urls = $opts{abs_urls};
 246   my $auto_images = $opts{auto_images};
 247   my $templater = $opts{templater};
 248   my $images = $opts{images};
 249   my $files = $opts{files};
 250
 251   return substr($body, 6) if $body =~ /^<html>/i;
 252
 253   my $formatter_class = $self->formatter_class;
 254
 255   my $formatter = $formatter_class->new(gen => $self,
 256                                         acts => $acts,
 257                                         articles => $articles,
 258                                         abs_urls => $abs_urls,
 259                                         auto_images => \$auto_images,
 260                                         images => $images,
 261                                         files => $files,
 262                                         templater => $templater);
 263
 264   $body = $formatter->format($body);
 265
 266   my $xhtml = $self->{cfg}->entry('basic', 'xhtml', 1);
 267
 268   # we don't format named images
 269   my @images = grep $_->{name} eq '', @$images;
 270   if ($auto_images
 271       && @images
 272       && $self->{cfg}->entry('basic', 'auto_images', 1)
 273       && $imagePos ne 'xx') {
 274     # the first image simply goes where we're told to put it
 275     # the imagePos is [tb][rl] (top|bottom)(right|left)
 276     my $align = $imagePos =~ /r/ ? 'right' : 'left';
 277
 278     # Offset the end a bit so we don't get an image hanging as obviously
 279     # off the end.
 280     # Numbers determined by trial - it can still look pretty rough.
 281     my $len = length $body;
 282     if ($len > 1000) {
 283       $len -= 500;
 284     }
 285     elsif ($len > 800) {
 286       $len -= 200;
 287     }
 288
 289     #my $incr = @images > 1 ? 2*$len / (2*@images+1) : 0;
 290     my $incr = $len / @images;
 291     # inserting the image tags moves character positions around
 292     # so we need the temp buffer
 293     if ($imagePos =~ /b/) {
 294       @images = reverse @images;
 295       if (@images % 2 == 0) {
 296         # starting at the bottom, swap it around
 297         $align = $align eq 'right' ? 'left' : 'right';
 298       }
 299     }
 300     my $output = '';
 301     for my $image (@images) {
 302       # adjust to make sure this isn't in the middle of a tag or entity
 303       my $pos = $self->adjust_for_html($body, $incr);
 304
 305       my $img = $image->inline(cfg => $self->{cfg}, align => $align);
 306       $output .= $img;
 307       $output .= substr($body, 0, $pos);
 308       substr($body, 0, $pos) = '';
 309       $align = $align eq 'right' ? 'left' : 'right';
 310     }
 311     $body = $output . $body; # don't forget the rest of it
 312   }
 313
 314   return make_entities($body);
 315 }
 316
 317 sub embed {
 318   my ($self, $article, $articles, $template) = @_;
 319
 320   if (defined $template && $template =~ /\$/) {
 321     $template =~ s/\$/$article->{template}/;
 322   }
 323   else {
 324     $template = $article->{template}
 325       unless defined($template) && $template =~ /\S/;
 326   }
 327
 328   my $html = BSE::Template->get_source($template, $self->{cfg});
 329
 330   # the template will hopefully contain <:embed start:> and <:embed end:>
 331   # tags
 332   # otherwise pull out the body content
 333   if ($html =~ /<:\s*embed\s*start\s*:>(.*)<:\s*embed\s*end\s*:>/s
 334      || $html =~ m"<\s*body[^>]*>(.*)<\s*/\s*body>"s) {
 335     $html = $1;
 336   }
 337   return $self->generate_low($html, $article, $articles, 1);
 338 }
 339
 340 sub iter_kids_of {
 341   my ($self, $state, $args, $acts, $name, $templater) = @_;
 342
 343   my $filter = $self->_get_filter(\$args);
 344
 345   $state->{parentid} = undef;
 346   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
 347   for my $id (@ids) {
 348     unless ($id =~ /^\d+$|^-1$/) {
 349       $id = $templater->perform($acts, $id, "id");
 350     }
 351   }
 352   @ids = grep /^\d+$|^-1$/, @ids;
 353   if (@ids == 1) {
 354     $state->{parentid} = $ids[0];
 355   }
 356   $self->_do_filter($filter, map Articles->listedChildren($_), @ids);
 357 }
 358
 359 my $cols_re; # cache for below
 360
 361 {
 362   my %expr_cache;
 363
 364   sub _get_filter {
 365     my ($self, $rargs) = @_;
 366
 367     if ($$rargs =~ s/filter:\s+(.*)\z//s) {
 368       my $expr = $1;
 369       my $orig_expr = $expr;
 370       unless ($cols_re) {
 371         my $cols_expr = '(' . join('|', Article->columns) . ')';
 372         $cols_re = qr/\[$cols_expr\]/;
 373       }
 374       $expr =~ s/$cols_re/\$article->{$1}/g;
 375       $expr =~ s/ARTICLE/\$article/g;
 376       #print STDERR "Expr $expr\n";
 377       my $filter = $expr_cache{$expr};
 378       unless ($filter) {
 379         $filter = eval 'sub { my $article = shift; '.$expr.'; }';
 380         if ($@) {
 381           print STDERR "** Failed to compile filter expression >>$expr<< built from >>$orig_expr<<\n";
 382           return;
 383         }
 384         $expr_cache{$expr} = $filter;
 385       }
 386
 387       return $filter;
 388     }
 389     else {
 390       return;
 391     }
 392   }
 393 }
 394
 395 sub _do_filter {
 396   my ($self, $filter, @articles) = @_;
 397
 398   $filter
 399     or return @articles;
 400
 401   return grep $filter->($_), @articles;
 402 }
 403
 404 sub iter_all_kids_of {
 405   my ($self, $state, $args, $acts, $name, $templater) = @_;
 406
 407   my $filter = $self->_get_filter(\$args);
 408
 409   $state->{parentid} = undef;
 410   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
 411   for my $id (@ids) {
 412     unless ($id =~ /^\d+$|^-1$/) {
 413       $id = $templater->perform($acts, $id, "id");
 414     }
 415   }
 416   @ids = grep /^\d+$|^-1$/, @ids;
 417   @ids == 1 and $state->{parentid} = $ids[0];
 418
 419   $self->_do_filter($filter, map Articles->all_visible_kids($_), @ids);
 420 }
 421
 422 sub iter_inlines {
 423   my ($self, $state, $args, $acts, $name, $templater) = @_;
 424
 425   my $filter = $self->_get_filter(\$args);
 426
 427   $state->{parentid} = undef;
 428   my @ids = map { split } DevHelp::Tags->get_parms($args, $acts, $templater);
 429   for my $id (@ids) {
 430     unless ($id =~ /^\d+$/) {
 431       $id = $templater->perform($acts, $id, "id");
 432     }
 433   }
 434   @ids = grep /^\d+$/, @ids;
 435   @ids == 1 and $state->{parentid} = $ids[0];
 436
 437   $self->_do_filter($filter, map Articles->getByPkey($_), @ids);
 438 }
 439
 440 sub iter_gimages {
 441   my ($self, $args) = @_;
 442
 443   unless ($self->{gimages}) {
 444     require BSE::TB::Images;
 445     my @gimages = BSE::TB::Images->getBy(articleId => -1);
 446     my %gimages = map { $_->{name} => $_ } @gimages;
 447     $self->{gimages} = \%gimages;
 448   }
 449
 450   my @gimages =
 451     sort { $a->{name} cmp $b->{name} } values %{$self->{gimages}};
 452   if ($args =~ m!^named\s+/([^/]+)/$!) {
 453     my $re = $1;
 454     return grep $_->{name} =~ /$re/i, @gimages;
 455   }
 456   else {
 457     return @gimages;
 458   }
 459 }
 460
 461 sub iter_gfiles {
 462   my ($self, $args) = @_;
 463
 464   unless ($self->{gfiles}) {
 465     my @gfiles = Articles->global_files;
 466     my %gfiles = map { $_->{name} => $_ } @gfiles;
 467     $self->{gfiles} = \%gfiles;
 468   }
 469
 470   my @gfiles =
 471     sort { $a->{name} cmp $b->{name} } values %{$self->{gfiles}};
 472   if ($args =~ m!^named\s+/([^/]+)/$!) {
 473     my $re = $1;
 474     return grep $_->{name} =~ /$re/i, @gfiles;
 475   }
 476   elsif ($args =~ m(^filter: (.*)$)s) {
 477     my $expr = $1;
 478     $expr =~ s/FILE\[(\w+)\]/\$file->$1/g;
 479     my $sub = eval 'sub { my $file = shift; ' . $expr . '; }';
 480     $sub
 481       or die "* Cannot compile sub from filter $expr: $@ *";
 482     return grep $sub->($_), @gfiles;
 483   }
 484   else {
 485     return @gfiles;
 486   }
 487 }
 488
 489 sub admin_tags {
 490   my ($self) = @_;
 491
 492   $self->{admin} or return;
 493
 494   return BSE::Util::Tags->secure($self->{request});
 495 }
 496
 497 sub _static_images {
 498   my ($self) = @_;
 499
 500   my $static = $self->{cfg}->entry('basic', 'static_thumbnails', 1);
 501   $self->{admin} and $static = 0;
 502   $self->{dynamic} and $static = 0;
 503
 504   return $static;
 505 }
 506
 507 # implements popimage and gpopimage
 508 sub do_popimage_low {
 509   my ($self, $im, $class) = @_;
 510
 511   return $im->popimage
 512     (
 513      cfg => $self->cfg,
 514      class => $class,
 515      static => $self->_static_images,
 516     );
 517
 518 }
 519
 520 sub do_gpopimage {
 521   my ($self, $image_id, $class) = @_;
 522
 523   my $im = $self->get_gimage($image_id)
 524     or return "* Unknown global image '$image_id' *";
 525
 526   return $self->do_popimage_low($im, $class);
 527 }
 528
 529 sub _sthumbimage_low {
 530   my ($self, $geometry, $im, $field) = @_;
 531
 532   return $self->_thumbimage_low($geometry, $im, $field, $self->{cfg}, $self->_static_images);
 533 }
 534
 535 sub tag_gthumbimage {
 536   my ($self, $rcurrent, $args, $acts, $name, $templater) = @_;
 537
 538   my ($geometry_id, $id, $field) = DevHelp::Tags->get_parms($args, $acts, $templater);
 539
 540   return $self->do_gthumbimage($geometry_id, $id, $field, $$rcurrent);
 541 }
 542
 543 sub _find_image {
 544   my ($self, $acts, $templater, $article_id, $image_tags, $msg) = @_;
 545
 546   my $article;
 547   if ($article_id =~ /^\d+$/) {
 548     require Articles;
 549     $article = Articles->getByPkey($article_id);
 550     unless ($article) {
 551       $$msg = "* no article $article_id found *";
 552       return;
 553     }
 554   }
 555   elsif ($acts->{$article_id}) {
 556     my $id = $templater->perform($acts, $article_id, "id");
 557     $article = Articles->getByPkey($id);
 558     unless ($article) {
 559       $$msg = "* article $article_id/$id not found *";
 560       return;
 561     }
 562   }
 563   else {
 564     ($article) = Articles->getBy(linkAlias => $article_id);
 565     unless ($article) {
 566       $$msg = "* no article $article_id found *";
 567       return;
 568     }
 569   }
 570   $article
 571     or return;
 572
 573   my @images = $article->images;
 574   my $im;
 575   for my $tag (split /,/, $image_tags) {
 576     if ($tag =~ m!^/(.*)/$!) {
 577       my $re = $1;
 578       ($im) = grep $_->{name} =~ /$re/i, @images
 579         and last;
 580     }
 581     elsif ($tag =~ /^\d+$/) {
 582       if ($tag >= 1 && $tag <= @images) {
 583         $im = $images[$tag-1];
 584         last;
 585       }
 586     }
 587     elsif ($tag =~ /^[^\W\d]\w*$/) {
 588       ($im) = grep $_->{name} eq $tag, @images
 589         and last;
 590     }
 591   }
 592   unless ($im) {
 593     $$msg = "* no image matching $image_tags found *";
 594     return;
 595   }
 596
 597   return $im;
 598 }
 599
 600 sub tag_sthumbimage {
 601   my ($self, $args, $acts, $name, $templater) = @_;
 602
 603   my ($article_id, $geometry, $image_tags, $field) = split ' ', $args;
 604
 605   my $msg;
 606   my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
 607     or return $msg;
 608
 609   return $self->_sthumbimage_low($geometry, $im, $field);
 610 }
 611
 612 sub tag_simage {
 613   my ($self, $args, $acts, $name, $templater) = @_;
 614
 615   my ($article_id, $image_tags, $field, $rest) = split ' ', $args, 4;
 616
 617   my $msg;
 618   my $im = $self->_find_image($acts, $templater, $article_id, $image_tags, \$msg)
 619     or return $msg;
 620
 621   return $self->_format_image($im, $field, $rest);
 622 }
 623
 624 =item iterator vimages I<articles> I<filter>
 625
 626 =item iterator vimages I<articles>
 627
 628 Iterates over the images belonging to the articles specified.
 629
 630 I<articles> can be any of:
 631
 632 =over
 633
 634 =item *
 635
 636 article - the current article
 637
 638 =item *
 639
 640 children - all visible children (including stepkids) of the current
 641 article
 642
 643 =item *
 644
 645 parent - the parent of the current article
 646
 647 =item *
 648
 649 I<number> - a numeric article id, such as C<10>.
 650
 651 =item *
 652
 653 alias(I<alias>) - a link alias of an article
 654
 655 =item *
 656
 657 childrenof(I<articles>) - an articles that are children of
 658 I<articles>.  I<articles> can be any normal article spec, so
 659 C<childrenof(childrenof(-1))> is valid.
 660
 661 =item *
 662
 663 I<tagname> - a tag name referring to an article.
 664
 665 =back
 666
 667 I<articles> has [] replacement done before parsing.
 668
 669 I<filter> can be missing, or either of:
 670
 671 =over
 672
 673 =item *
 674
 675 named /I<regexp>/ - images with names matching the given regular
 676 expression
 677
 678 =item *
 679
 680 numbered I<number> - images with the given index.
 681
 682 =back
 683
 684 Items for this iterator are vimage and vthumbimage.
 685
 686 =cut
 687
 688 sub iter_vimages {
 689   my ($self, $article, $args, $acts, $name, $templater) = @_;
 690
 691   my $re;
 692   my $num;
 693   if ($args =~ s!\s+named\s+/([^/]+)/$!!) {
 694     $re = $1;
 695   }
 696   elsif ($args =~ s!\s+numbered\s+(\d+)$!!) {
 697     $num = $1;
 698   }
 699   my @args = DevHelp::Tags->get_parms($args, $acts, $templater);
 700   my @images;
 701   for my $article_id (map { split /[, ]/ } @args) {
 702     my @articles = $self->_find_articles($article_id, $article, $acts, $name, $templater);
 703     for my $article (@articles) {
 704       my @aimages = $article->images;
 705       if (defined $re) {
 706         push @images, grep $_->{name} =~ /$re/, @aimages;
 707       }
 708       elsif (defined $num) {
 709         if ($num >= 0 && $num <= @aimages) {
 710           push @images, $aimages[$num-1];
 711         }
 712       }
 713       else {
 714         push @images, @aimages;
 715       }
 716     }
 717   }
 718
 719   return @images;
 720 }
 721
 722 =item vimage field
 723
 724 =item vimage
 725
 726 Retrieve the given field from the current vimage, or display the image.
 727
 728 =cut
 729
 730 sub tag_vimage {
 731   my ($self, $rvimage, $args) = @_;
 732
 733   $$rvimage or return '** no current vimage **';
 734
 735   my ($field, $rest) = split ' ', $args, 2;
 736
 737   return $self->_format_image($$rvimage, $field, $rest);
 738 }
 739
 740 =item vthumbimage geometry field
 741
 742 =item vthumbimage geometry
 743
 744 Retrieve the given field from the thumbnail of the current vimage or
 745 display the thumbnail.
 746
 747 =cut
 748
 749 sub tag_vthumbimage {
 750   my ($self, $rvimage, $args) = @_;
 751
 752   $$rvimage or return '** no current vimage **';
 753   my ($geo, $field) = split ' ', $args;
 754
 755   return $self->_sthumbimage_low($geo, $$rvimage, $field);
 756 }
 757
 758 sub _find_articles {
 759   my ($self, $article_id, $article, $acts, $name, $templater) = @_;
 760
 761   if ($article_id =~ /^\d+$/) {
 762     my $result = Articles->getByPkey($article_id);
 763     $result or print STDERR "** Unknown article id $article_id **\n";
 764     return $result ? $result : ();
 765   }
 766   elsif ($article_id =~ /^alias\((\w+)\)$/) {
 767     my $result = Articles->getBy(linkAlias => $1);
 768     $result or print STDERR "** Unknown article alias $article_id **\n";
 769     return $result ? $result : ();
 770   }
 771   elsif ($article_id =~ /^childrenof\((.*)\)$/) {
 772     my $id = $1;
 773     if ($id eq '-1') {
 774       return Articles->all_visible_kids(-1);
 775     }
 776     else {
 777       my @parents = $self->_find_articles($id)
 778         or return;
 779       return map $_->all_visible_kids, @parents;
 780     }
 781   }
 782   elsif ($acts->{$article_id}) {
 783     my $id = $templater->perform($acts, $article_id, 'id');
 784     if ($id && $id =~ /^\d+$/) {
 785       return Articles->getByPkey($id);
 786     }
 787   }
 788   print STDERR "** Unknown article identifier $article_id **\n";
 789
 790   return;
 791 }
 792
 793 sub baseActs {
 794   my ($self, $articles, $acts, $article, $embedded) = @_;
 795
 796   # used to generate the side menu
 797   my $section_index = -1;
 798   my @sections = $articles->listedChildren(-1);
 799     #sort { $a->{displayOrder} <=> $b->{displayOrder} }
 800     #grep $_->{listed}, $articles->sections;
 801   my $subsect_index = -1;
 802   my @subsections; # filled as we move through the sections
 803   my @level3; # filled as we move through the subsections
 804   my $level3_index = -1;
 805
 806   my $cfg = $self->{cfg} || BSE::Cfg->single;
 807   my %extras = $cfg->entriesCS('extra tags');
 808   for my $key (keys %extras) {
 809     # follow any links
 810     my $data = $cfg->entryVar('extra tags', $key);
 811     $extras{$key} = sub { $data };
 812   }
 813
 814   my $current_gimage;
 815   my $current_vimage;
 816   my $it = BSE::Util::Iterate->new;
 817   my $art_it = BSE::Util::Iterate::Article->new(cfg => $cfg,
 818                                                 admin => $self->{admin},
 819                                                 top => $self->{top});
 820   return
 821     (
 822      %extras,
 823
 824      custom_class($cfg)->base_tags($articles, $acts, $article, $embedded, $cfg),
 825      $self->admin_tags(),
 826      BSE::Util::Tags->static($acts, $self->{cfg}),
 827      # for embedding the content from children and other sources
 828      ifEmbedded=> sub { $embedded },
 829      embed => sub {
 830        my ($args, $acts, $name, $templater) = @_;
 831        my ($what, $template, $maxdepth) = split ' ', $args;
 832        undef $maxdepth if defined $maxdepth && $maxdepth !~ /^\d+/;
 833        return $self->_embed_low($acts, $articles, $what, $template, $maxdepth, $templater);
 834      },
 835      ifCanEmbed=> sub { $self->{depth} <= $self->{maxdepth} },
 836
 837      summary =>
 838      sub {
 839        my ($args, $acts, $name, $templater) = @_;
 840        my ($which, $limit) = DevHelp::Tags->get_parms($args, $acts, $templater);
 841        $which or $which = "child";
 842        $limit or $limit = $article->{summaryLength};
 843        $acts->{$which}
 844          or return "<:summary $which Cannot find $which:>";
 845        my $id = $templater->perform($acts, $which, "id")
 846          or return "<:summary $which No id returned :>";
 847        my $article = $articles->getByPkey($id)
 848          or return "<:summary $which Cannot find article $id:>";
 849        return $self->summarize($articles, $article->{body}, $acts, $limit);
 850      },
 851      ifAdmin => sub { $self->{admin} },
 852      ifAdminLinks => sub { $self->{admin_links} },
 853
 854      # for generating the side menu
 855      iterate_level1_reset => sub { $section_index = -1 },
 856      iterate_level1 => sub {
 857        ++$section_index;
 858        if ($section_index < @sections) {
 859          #@subsections = grep $_->{listed},
 860          #  $articles->children($sections[$section_index]->{id});
 861          @subsections = grep { $_->{listed} != 2 }
 862            $articles->listedChildren($sections[$section_index]->{id});
 863          $subsect_index = -1;
 864          return 1;
 865        }
 866        else {
 867          return 0;
 868        }
 869      },
 870      level1 => sub {
 871        return tag_article($sections[$section_index], $cfg, $_[0]);
 872      },
 873
 874      # used to generate a list of subsections for the side-menu
 875      iterate_level2 => sub {
 876        ++$subsect_index;
 877        if ($subsect_index < @subsections) {
 878          @level3 = grep { $_->{listed} != 2 }
 879            $articles->listedChildren($subsections[$subsect_index]{id});
 880          $level3_index = -1;
 881          return 1;
 882        }
 883        return 0;
 884      },
 885      level2 => sub {
 886        return tag_article($subsections[$subsect_index], $cfg, $_[0]);
 887      },
 888      ifLevel2 =>
 889      sub {
 890        return scalar @subsections;
 891      },
 892
 893      # possibly level3 items
 894      iterate_level3 => sub {
 895        return ++$level3_index < @level3;
 896      },
 897      level3 => sub {
 898        tag_article($level3[$level3_index], $cfg, $_[0])
 899      },
 900      ifLevel3 => sub { scalar @level3 },
 901
 902      # generate an admin or link url, depending on admin state
 903      url=>
 904      sub {
 905        my ($name, $acts, $func, $templater) = @_;
 906        my $item = $self->{admin_links} ? 'admin' : 'link';
 907        $acts->{$name}
 908          or die "ENOIMPL\n";
 909        my $url = $templater->perform($acts, $name, $item);
 910        if (!$self->{admin} && $self->{admin_links}) {
 911          $url .= $url =~ /\?/ ? "&" : "?";
 912          $url .= "admin=0&admin_links=1";
 913        }
 914        return $url;
 915      },
 916      ifInMenu =>
 917      sub {
 918        $acts->{$_[0]} or return 0;
 919        return $acts->{$_[0]}->('listed') == 1;
 920      },
 921      titleImage=>
 922      sub {
 923        my ($image, $text) = split ' ', $_[0];
 924        if (-e $IMAGEDIR."/titles/".$image) {
 925          return qq!<img src="/images/titles/!.$image .qq!" border=0>!
 926        }
 927        else {
 928          return escape_html($text);
 929        }
 930      },
 931      $art_it->make( code => [ iter_kids_of => $self ],
 932                     single => 'ofchild',
 933                     plural => 'children_of',
 934                     nocache => 1,
 935                     state => 1 ),
 936      $art_it->make( code => [ iter_kids_of => $self ],
 937                     single => 'ofchild2',
 938                     plural => 'children_of2',
 939                     nocache => 1,
 940                     state => 1 ),
 941      $art_it->make( code => [ iter_kids_of => $self ],
 942                     single => 'ofchild3',
 943                     plural => 'children_of3',
 944                     nocache => 1,
 945                     state => 1 ),
 946      $art_it->make( code => [ iter_all_kids_of => $self ],
 947                     single => 'ofallkid',
 948                     plural => 'allkids_of',
 949                     state => 1 ),
 950      $art_it->make( code => [ iter_all_kids_of => $self ],
 951                     single => 'ofallkid2',
 952                     plural => 'allkids_of2',
 953                     nocache => 1,
 954                     state => 1 ),
 955      $art_it->make( code => [ iter_all_kids_of => $self ],
 956                     single => 'ofallkid3',
 957                     plural => 'allkids_of3',
 958                     nocache => 1,
 959                     state => 1 ),
 960      $art_it->make( code => [ iter_all_kids_of => $self ],
 961                     single => 'ofallkid4',
 962                     plural => 'allkids_of4',
 963                     nocache => 1,
 964                     state => 1 ),
 965      $art_it->make( code => [ iter_all_kids_of => $self ],
 966                     single => 'ofallkid5',
 967                     plural => 'allkids_of5',
 968                     nocache => 1,
 969                     state => 1 ),
 970      $art_it->make( code => [ iter_inlines => $self ],
 971                     single => 'inline',
 972                     plural => 'inlines',
 973                     nocache => 1,
 974                     state => 1 ),
 975      gimage =>
 976      sub {
 977        my ($args, $acts, $func, $templater) = @_;
 978        my ($name, $align, @rest) =
 979          DevHelp::Tags->get_parms($args, $acts, $templater);
 980        my $rest = "@rest";
 981
 982        my $im;
 983        if ($name eq '-') {
 984          $im = $current_gimage
 985            or return '';
 986        }
 987        else {
 988          $im = $self->get_gimage($name)
 989            or return '';
 990        }
 991
 992        $self->_format_image($im, $align, $rest);
 993      },
 994      $it->make_iterator( [ \&iter_gimages, $self ], 'gimagei', 'gimages',
 995                          undef, undef, undef, \$current_gimage),
 996      gfile =>
 997      sub {
 998        my ($name, $field) = split ' ', $_[0], 3;
 999
1000        my $file = $self->get_gfile($name)
1001          or return '';
1002
1003        $self->_format_file($file, $field);
1004      },
1005      $it->make_iterator( [ \&iter_gfiles, $self ], 'gfilei', 'gfiles'),
1006      gthumbimage => [ tag_gthumbimage => $self, \$current_gimage ],
1007      sthumbimage => [ tag_sthumbimage => $self ],
1008      simage => [ tag_simage => $self ],
1009      $it->make_iterator( [ iter_vimages => $self, $article ], 'vimage', 'vimages', undef, undef, undef, \$current_vimage),
1010      vimage => [ tag_vimage => $self, \$current_vimage ],
1011      vthumbimage => [ tag_vthumbimage => $self, \$current_vimage ],
1012     );
1013 }
1014
1015 sub find_terms {
1016   my ($body, $case_sensitive, $terms) = @_;
1017
1018   # locate the terms
1019   my @found;
1020   if ($case_sensitive) {
1021     for my $term (@$terms) {
1022       if ($$body =~ /^(.*?)\Q$term/s) {
1023         push(@found, [ length($1), $term ]);
1024       }
1025     }
1026   }
1027   else {
1028     for my $term (@$terms) {
1029       if ($$body =~ /^(.*?)\Q$term/is) {
1030         push(@found, [ length($1), $term ]);
1031       }
1032     }
1033   }
1034
1035   return @found;
1036 }
1037
1038 # this takes the same inputs as _make_table(), but eliminates any
1039 # markup instead
1040 sub _cleanup_table {
1041   my ($opts, $data) = @_;
1042   my @lines = split /\n/, $data;
1043   for (@lines) {
1044     s/^[^|]*\|//;
1045     tr/|/ /s;
1046   }
1047   return join(' ', @lines);
1048 }
1049
1050 # produce a nice excerpt for a found article
1051 sub excerpt {
1052   my ($self, $article, $found, $case_sensitive, $terms, $type, $body) = @_;
1053
1054   if (!$body) {
1055     $body = $article->{body};
1056
1057     # we remove any formatting tags here, otherwise we get wierd table
1058     # rubbish or other formatting in the excerpt.
1059     my @files = $article->files;
1060     $self->remove_block('Articles', [], \$body, \@files);
1061     1 while $body =~ s/[bi]\[([^\]\[]+)\]/$1/g;
1062   }
1063
1064   $body = escape_html($body);
1065
1066   $type ||= 'body';
1067
1068   my @found = find_terms(\$body, $case_sensitive, $terms);
1069
1070   my @reterms = @$terms;
1071   for (@reterms) {
1072     tr/ / /s;
1073     $_ = quotemeta;
1074     s/\\?\s+/\\s+/g;
1075   }
1076   # do a reverse sort so that the longer terms (and composite
1077   # terms) are replaced first
1078   my $re_str = join("|", reverse sort @reterms);
1079   my $re;
1080   my $cfg = $self->{cfg};
1081   if ($cfg->entryBool('search', 'highlight_partial', 1)) {
1082     $re = $case_sensitive ? qr/\b($re_str)/ : qr/\b($re_str)/i;
1083   }
1084   else {
1085     $re = $case_sensitive ? qr/\b($re_str)\b/ : qr/\b($re_str)\b/i;
1086   }
1087
1088   # this used to try searching children as well, but it broke more
1089   # than it fixed
1090   if (!@found) {
1091     # we tried hard and failed
1092     # return a generic article
1093     if (length $body > $excerptSize) {
1094       $body = substr($body, 0, $excerptSize);
1095       $body =~ s/\S+\s*$/.../;
1096     }
1097     $$found = 0;
1098     return $body;
1099   }
1100
1101   # only the first 5
1102   splice(@found, 5,-1) if @found > 5;
1103   my $itemSize = $excerptSize / @found;
1104
1105   # try to combine any that are close
1106   @found = sort { $a->[0] <=> $b->[0] } @found;
1107   for my $i (reverse 0 .. $#found-1) {
1108     if ($found[$i+1][0] - $found[$i][0] < $itemSize) {
1109       my @losing = @{$found[$i+1]};
1110       shift @losing;
1111       push(@{$found[$i]}, @losing);
1112       splice(@found, $i+1, 1); # remove it
1113     }
1114   }
1115
1116   my $highlight_prefix =
1117     $cfg->entry('search highlight', "${type}_prefix", "<b>");
1118   my $highlight_suffix =
1119     $cfg->entry('search highlight', "${type}_suffix", "</b>");
1120   my $termSize = $excerptSize / @found;
1121   my $result = '';
1122   for my $term (@found) {
1123     my ($pos, @terms) = @$term;
1124     my $start = $pos - $termSize/2;
1125     my $part;
1126     if ($start < 0) {
1127       $start = 0;
1128       $part = substr($body, 0, $termSize);
1129     }
1130     else {
1131       $result .= "...";
1132       $part = substr($body, $start, $termSize);
1133       $part =~ s/^\w+//;
1134     }
1135     if ($start + $termSize < length $body) {
1136       $part =~ s/\s*\S*$/... /;
1137     }
1138     $result .= $part;
1139   }
1140   $result =~ s{$re}{$highlight_prefix$1$highlight_suffix}ig;
1141   $$found = 1;
1142
1143   return $result;
1144 }
1145
1146 sub visible {
1147   return 1;
1148 }
1149
1150
1151 # make whatever text $body points at safe for summarizing by removing most
1152 # block level formatting
1153 sub remove_block {
1154   my ($self, $articles, $acts, $body, $files) = @_;
1155
1156   my $formatter_class = $self->formatter_class;
1157
1158   $files ||= [];
1159
1160   my $formatter = $formatter_class->new(gen => $self,
1161                                       acts => $acts,
1162                                       article => $articles,
1163                                       articles => $articles,
1164                                       files => $files);
1165
1166   $$body = $formatter->remove_format($$body);
1167 }
1168
1169 sub get_gimage {
1170   my ($self, $name) = @_;
1171
1172   unless ($self->{gimages}) {
1173     require BSE::TB::Images;
1174     my @gimages = BSE::TB::Images->getBy(articleId => -1);
1175     my %gimages = map { $_->{name} => $_ } @gimages;
1176     $self->{gimages} = \%gimages;
1177   }
1178
1179   return $self->{gimages}{$name};
1180 }
1181
1182 sub get_gfile {
1183   my ($self, $name) = @_;
1184
1185   unless ($self->{gfiles}) {
1186     my @gfiles = Articles->global_files;
1187     my %gfiles = map { $_->{name} => $_ } @gfiles;
1188     $self->{gfiles} = \%gfiles;
1189   }
1190
1191   return $self->{gfiles}{$name};
1192 }
1193
1194 # note: this is called by BSE::Formatter::thumbimage(), update that if
1195 # this is changed
1196 sub do_gthumbimage {
1197   my ($self, $geo_id, $image_id, $field, $current) = @_;
1198
1199   my $im;
1200   if ($image_id eq '-' && $current) {
1201     $im = $current;
1202   }
1203   else {
1204     $im = $self->get_gimage($image_id);
1205   }
1206   $im
1207     or return '** unknown global image id **';
1208
1209   return $self->_sthumbimage_low($geo_id, $im, $field);
1210 }
1211
1212 sub get_real_article {
1213   my ($self, $article) = @_;
1214
1215   return $article;
1216 }
1217
1218 1;
1219
1220 __END__
1221
1222 =head1 NAME
1223
1224 Generate - provides base Squirel::Template actions for use in generating
1225 pages.
1226
1227 =head1 SYNOPSIS
1228
1229 =head1 DESCRIPTION
1230
1231 This is probably better documented in L<templates.pod>.
1232
1233 =head1 COMMON TAGS
1234
1235 These tags can be used anywhere, including in admin templates.  It's
1236 possible some admin code has been missed, if you find a place where
1237 these cannot be used let us know.
1238
1239
1240 =over
1241
1242 =item kb I<data tag>
1243
1244 Formats the give value in kI<whatevers>.  If you have a number that
1245 could go over 1000 and you want it to use the 'k' metric prefix when
1246 it does, use this tag.  eg. <:kb file sizeInBytes:>
1247
1248 =item date I<data tag>
1249
1250 =item date "I<format>" I<data tag>
1251
1252 Formats a date or date/time value from the database into something
1253 more human readable.  If you don't supply a format then the default
1254 format of "%d-%b-%Y" is used ("20-Mar-2002").
1255
1256 The I<format> is a strftime() format specification, if that means
1257 anything to you.  If it doesn't, each code starts with % and are
1258 replaced as follows:
1259
1260 =over
1261
1262 =item %a
1263
1264 abbreviated weekday name
1265
1266 =item %A
1267
1268 full weekday name
1269
1270 =item %b
1271
1272 abbreviated month name
1273
1274 =item %B
1275
1276 full month name
1277
1278 =item %c
1279
1280 "preferred" date and time representation
1281
1282 =item %d
1283
1284 day of the month as a 2 digit number
1285
1286 =item %H
1287
1288 hour (24-hour clock)
1289
1290 =item %I
1291
1292 hour (12-hour clock)
1293
1294 =item %j
1295
1296 day of year as a 3-digit number
1297
1298 =item %m
1299
1300 month as a 2 digit number
1301
1302 =item %M
1303
1304 minute as a 2 digit number
1305
1306 =item %p
1307
1308 AM or PM or their equivalents
1309
1310 =item %S
1311
1312 seconds as a 2 digit number
1313
1314 =item %U
1315
1316 week number as a 2 digit number (first Sunday as the first day of week 1)
1317
1318 =item %w
1319
1320 weekday as a decimal number (0-6)
1321
1322 =item %W
1323
1324 week number as a 2 digit number (first Monday as the first day of week 1)
1325
1326 =item %x
1327
1328 the locale's appropriate date representation
1329
1330 =item %X
1331
1332 the locale's appropriate time representation
1333
1334 =item %y
1335
1336 2-digit year without century
1337
1338 =item %Y
1339
1340 the full year
1341
1342 =item %Z
1343
1344 time zone name or abbreviation
1345
1346 =item %%
1347
1348 just '%'
1349
1350 =back
1351
1352 Your local strftime() implementation may implement some extensions to
1353 the above, if your server is on a Unix system try running "man
1354 strftime" for more information.
1355
1356 =item bodytext I<data tag>
1357
1358 Formats the text from the given tag in the same way that body text is.
1359
1360 =item ifEq I<data1> I<data2>
1361
1362 Checks if the 2 values are exactly equal.  This is a string
1363 comparison.
1364
1365 The 2 data parameters can either be a tag reference in [], a literal
1366 string inside "" or a single word.
1367
1368 =item ifMatch I<data1> I<data2>
1369
1370 Treats I<data2> as a perl regular expression and attempts to match
1371 I<data1> against it.
1372
1373 The 2 data parameters can either be a tag reference in [], a literal
1374 string inside "" or a single word.
1375
1376 =item cfg I<section> I<key>
1377
1378 =item cfg I<section> I<key> I<default>
1379
1380 Retrieves a value from the BSE configuration file.
1381
1382 If you don't supply a default then a default will be the empty string.
1383
1384 =item release
1385
1386 The release number of BSE.
1387
1388 =back
1389
1390 =head1 TAGS
1391
1392 =over 4
1393
1394 =item ifAdmin
1395
1396 Conditional tag, true if generating in admin mode.
1397
1398 =item iterator ... level1
1399
1400 Iterates over the listed level 1 articles.
1401
1402 =item level1 I<name>
1403
1404 The value of the I<name> field of the current level 1 article.
1405
1406 =item iterator ... level2
1407
1408 Iterates over the listed level 2 children of the current level 1 article.
1409
1410 =item level2 I<name>
1411
1412 The value of the I<name> field of the current level 2 article.
1413
1414 =item ifLevel2 I<name>
1415
1416 Conditional tag, true if the current level 1 article has any listed
1417 level 2 children.
1418
1419 =item iterator ... level3
1420
1421 Iterates over the listed level 3 children of the current level 2 article.
1422
1423 =item level3 I<name>
1424
1425 The value of the I<name> field of the current level 3 article.
1426
1427 =item ifLevel3 I<name>
1428
1429 Conditional tag, true if the current level 2 article has any listed
1430 level 3 children.
1431
1432 =item url I<which>
1433
1434 Returns a link to the specified article .  Due to the way the action
1435 list is built, this can be article types defined in derived classes of
1436 Generate, like the C<parent> article in Generate::Article.
1437
1438 =item money I<data tag>
1439
1440 Formats the given value as a monetary value.  This does not include a
1441 currency symbol.  Internally BSE stores monetary values as integers to
1442 prevent the loss of accuracy inherent in floating point numbers.  You
1443 need to use this tag to display any monetary value.
1444
1445 =item ifInMenu I<which>
1446
1447 Conditional tag, true if the given item can appear in a menu.
1448
1449 =item titleImage I<imagename> I<text>
1450
1451 Generates an IMG tag if the given I<imagename> is in the title image
1452 directory ($IMAGEDIR/titles).  If it doesn't exists, produces the
1453 I<text>.
1454
1455 =item embed I<which>
1456
1457 =item embed I<which> I<template>
1458
1459 =item embed I<which> I<template> I<maxdepth>
1460
1461 =item embed child
1462
1463 Embeds the article specified by which using either the specified
1464 template or the articles template.
1465
1466 In this case I<which> can also be an article ID.
1467
1468 I<template> is a filename relative to the templates directory.  If
1469 this is "-" then the articles template is used (so you can set
1470 I<maxdepth> without setting the template.)  If I<template> contains a
1471 C<$> sign it will be replaced with the name of the original template.
1472
1473 If I<maxdepth> is supplied and is less than the current maximum depth
1474 then it becomes the new maximum depth.  This can be used with ifCanEmbed.
1475
1476 =item embed start ... embed end
1477
1478 Marks the range of text that would be embedded in a parent that used
1479 C<embed child>.
1480
1481 =item ifEmbedded
1482
1483 Conditional tag, true if the current article is being embedded.
1484
1485 =back
1486
1487 =head1 BUGS
1488
1489 Needs more documentation.
1490
1491 =cut