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