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