site/cgi-bin/modules/BSE/Formatter.pm

   1 package BSE::Formatter;
   2 use strict;
   3 use DevHelp::HTML;
   4 use Carp 'confess';
   5 use Digest::MD5 qw(md5_hex);
   6
   7 use base 'DevHelp::Formatter';
   8
   9 my $pop_nameid = 'AAAAAA';
  10
  11 sub new {
  12   my $class = shift;
  13
  14   my (%opts) =
  15     (
  16      images => [],
  17      files => [],
  18      abs_urls => 0,
  19      acts => {},
  20      @_
  21     );
  22
  23   my $self = $class->SUPER::new;
  24
  25   $self->{gen} = $opts{gen};
  26   $self->{acts} = $opts{acts};
  27   $self->{articles} = $opts{articles};
  28   $self->{abs_urls} = $opts{abs_urls};
  29   my $dummy;
  30   $self->{auto_images} = $opts{auto_images} || \$dummy;
  31   $self->{images} = $opts{images};
  32   $self->{files} = $opts{files};
  33   $self->{templater} = $opts{templater};
  34
  35   my $cfg = $self->{gen}->{cfg};
  36   if ($cfg->entry('html', 'mbcs', 0)) {
  37     $self->{conservative_escape} = 1;
  38   }
  39   elsif ($cfg->entry('html', 'msentify', 0)) {
  40     $self->{msentify} = 1;
  41   }
  42
  43   $self->{redirect_links} = $cfg->entry('html', 'redirect_links', '');
  44   $self->{redirect_salt} = $cfg->entry('html', 'redirect_salt', '');
  45
  46   $self;
  47 }
  48
  49 sub _image {
  50   my ($self, $im, $align, $url, $style) = @_;
  51
  52   my $text = qq!<img src="/images/$im->{image}" width="$im->{width}"!
  53     . qq! height="$im->{height}" alt="! . escape_html($im->{alt}).'"'
  54       . qq! border="0"!;
  55   $text .= qq! align="$align"! if $align && $align ne 'center';
  56   if ($style) {
  57     if ($style =~ /^\d/) {
  58       $text .= qq! style="padding: $style"!;
  59     }
  60     elsif ($style =~ /^\w+$/) {
  61       $text .= qq! class="$style"!;
  62     }
  63     else {
  64       $text .= qq! style="$style"!;
  65     }
  66   }
  67   $text .= qq! />!;
  68   $text = qq!<div align="center">$text</div>!
  69     if $align && $align eq 'center';
  70   # the text in $url would have been HTML escaped already, the url
  71   # in the image record hasn't been
  72   if (!$url && $im->{url}) {
  73     $url = escape_html($im->{url});
  74   }
  75   if ($url) {
  76     $text = qq!<a href="$url">$text</a>!;
  77   }
  78
  79   return $text;
  80 }
  81
  82 sub gimage {
  83   my ($self, $args) = @_;
  84
  85   my ($name, $align, $url, $style) = split /\|/, $args, 4;
  86   my $im = $self->{gen}->get_gimage($name);
  87   if ($im) {
  88     $self->_image($im, $align, $url);
  89   }
  90   else {
  91     return '';
  92   }
  93 }
  94
  95 sub image {
  96   my ($self, $args) = @_;
  97
  98   my $images = $self->{images};
  99   my ($index, $align, $url, $style) = split /\|/, $args, 4;
 100   my $text = '';
 101   my $im;
 102   if ($index =~ /^\d+$/) {
 103     if ($index >=1 && $index <= @$images) {
 104       $im = $images->[$index-1];
 105       ${$self->{auto_images}} = 0;
 106     }
 107   }
 108   elsif ($index =~ /^[a-z]\w*$/i){
 109     # scan the names
 110     for my $image (@$images) {
 111       if ($image->{name} && lc $image->{name} eq lc $index) {
 112         $im = $image;
 113         last;
 114       }
 115     }
 116   }
 117   if ($im) {
 118     return $self->_image($im, $align, $url, $style);
 119   }
 120   else {
 121     return '';
 122   }
 123 }
 124
 125 sub embed {
 126   my ($self, $name, $templateid, $maxdepth) = @_;
 127
 128   $self->{gen}->_embed_low($self->{acts}, $self->{articles}, $name,
 129                            $templateid, $maxdepth, $self->{templater});
 130 }
 131
 132 sub link {
 133   my ($self, $url, $text) = @_;
 134
 135   if ($self->{redirect_links} =~ /[^\W\d]/) {
 136     my $noredir_types = join '|', map quotemeta, split /,/, $self->{redirect_links};
 137     if ($url =~ /^($noredir_types):/) {
 138       return $self->SUPER::link($url, $text);
 139     }
 140   }
 141   elsif (!$self->{redirect_links} || $url =~ /^mailto:/ || $url =~ /^\#/) {
 142     return $self->SUPER::link($url, $text);
 143   }
 144
 145   # formatter converted & to &amp; but we want them as & so they undergo
 146   # uri conversion correctly
 147   $url = unescape_html($url);
 148   $text = unescape_html($text);
 149   my $redir_hash = substr(md5_hex($url, $text, $self->{redirect_salt}), 0, 16);
 150
 151   my $new_url = '/cgi-bin/nuser.pl/redirect?url='
 152     . escape_uri($url) . "&amp;h=$redir_hash";
 153   if ($url ne $text) {
 154     $new_url .= '&amp;title=' . escape_uri($text);
 155   }
 156
 157   return $self->SUPER::link($new_url, $text);
 158 }
 159
 160 sub _get_article {
 161   my ($self, $id, $error) = @_;
 162
 163   my $cfg = $self->{gen}->{cfg}
 164     or confess "cfg not set in acts";
 165   my $dispid;
 166   if ($id =~ /^\d+$/) {
 167     $dispid = $id;
 168   }
 169   else {
 170     # try to find it in the config
 171     my $work = $cfg->entry('articles', $id);
 172     unless ($work) {
 173       $$error = "&#42;&#42; No article name '".escape_html($id)."' in the [articles] section of bse.cfg &#42;&#42;";
 174       return;
 175     }
 176     $dispid = "$id ($work)";
 177     $id = $work;
 178   }
 179   my $art = $self->{articles}->getByPkey($id);
 180   unless ($art) {
 181     $$error = "&#42;&#42; Cannot find article id $dispid &#42;&#42;";
 182     return;
 183   }
 184
 185   return $art;
 186 }
 187
 188 sub doclink {
 189   my ($self, $id, $title, $target, $type) = @_;
 190
 191   my $error;
 192   my $art = $self->_get_article($id, \$error)
 193     or return $error;
 194
 195   my $cfg = $self->{gen}->{cfg}
 196     or confess "cfg not set in acts";
 197
 198   # make the URL absolute if necessary
 199   my $admin = $self->{gen}{admin};
 200   my $link = $admin ? 'admin' : 'link';
 201   my $url = $art->{$link};
 202   if ($self->{abs_urls}) {
 203     $url = $cfg->entryErr('site', 'url') . $url
 204       unless $url =~ /^\w+:/;
 205   }
 206   $url = escape_html($url);
 207
 208   unless ($title) {
 209     $title = escape_html($art->{title});
 210   }
 211
 212   $target = $target ? qq! target="$target"! : '';
 213   my $title_attrib = escape_html($art->{title});
 214   my $class_text = '';
 215   if ($type) {
 216     my $class = $self->tag_class($type);
 217     if ($class) {
 218       $class_text = qq/ class="$class"/;
 219     }
 220   }
 221
 222   return qq!<a href="$url" title="$title_attrib"$target$class_text>$title</a>!;
 223 }
 224
 225 sub popimage {
 226   my ($self, $args) = @_;
 227
 228   my $image_id;
 229   my ($image1_name, $image2_name, $align, $style) = split /\|/, $args;
 230
 231   my $style_tag = '';
 232   if ($style =~ /^\d/) {
 233     $style_tag = qq! style="padding: $style"!;
 234   }
 235   elsif ($style =~ /^\w+$/) {
 236     $style_tag = qq! class="$style"!;
 237   }
 238   else {
 239     $style_tag = qq! style="$style"!;
 240   }
 241
 242   # work out the content inside the link
 243   my $inside;
 244   my $images = $self->{images};
 245   if ($image1_name =~ /^\w+$/) {
 246     my $image1;
 247     if ($image1_name =~ /^\d+$/) {
 248       if ($image1_name >= 1 && $image1_name <= @$images) {
 249         $image1 = $images->[$image1_name - 1];
 250       }
 251       else {
 252         return '';
 253       }
 254     }
 255     else {
 256       ($image1) = grep $_->{name} && lc $_->{name} eq lc $image1_name,
 257         @$images;
 258     }
 259
 260     $inside = qq!<img src="/images/$image1->{image}" !
 261       . qq!width="$image1->{width}" height="$image1->{height}"!
 262         . qq! alt="! . escape_html($image1->{alt})
 263           .qq!" border="0"!;
 264     $inside .= qq! align="$align"! if $align && $align ne 'center';
 265     $inside .= $style_tag;
 266     $image_id = 'popimage_' . $pop_nameid++;
 267
 268     $inside .= qq! name="$image_id" />!;
 269   }
 270   else {
 271     $inside = $image1_name;
 272     $image_id = '';
 273   }
 274
 275   # resolve the second image
 276   my $image2;
 277   if ($image2_name =~ /^\d+$/) {
 278     if ($image2_name >= 1 and $image2_name < @$images) {
 279       $image2 = $images->[$image2_name - 1];
 280     }
 281     else {
 282       return '';
 283     }
 284   }
 285   elsif ($image2_name =~ /^\w+$/) {
 286     ($image2) = grep $_->{name} && lc $_->{name} eq lc $image2_name,
 287       @$images
 288         or return '';
 289   }
 290   else {
 291     return "** Unknown image2 $image2_name **";
 292   }
 293
 294   my $href = '/cgi-bin/image.pl?id=' . $image2->{articleId}
 295     . '&amp;imid=' . $image2->{id};
 296   my $popup_url = "/images/" . $image2->{image};
 297   my $javascript =
 298     "return bse_popup_image($image2->{articleId}, $image2->{id}, "
 299       . "$image2->{width}, $image2->{height}, '$image_id', '$popup_url')";
 300   my $link_start = qq!<a href="$href" onclick="$javascript" target="bse_image">!;
 301   my $link_end = "</a>";
 302
 303   if ($image_id) {
 304     if ($align eq 'center') {
 305       $link_start = qq!<div align="center">! . $link_start;
 306       $link_end .= '</div>';
 307     }
 308   }
 309   else {
 310     if ($align) {
 311       $link_start = qq!<div align="$align"$style_tag>! . $link_start;
 312       $link_end .= "</div>";
 313     }
 314     elsif ($style_tag) {
 315       $link_start = "<div$style_tag>".$link_start;
 316       $link_end .= "</div>";
 317     }
 318   }
 319
 320   return $self->_fix_spanned($link_start, $link_end, $inside);
 321 }
 322
 323 sub filelink {
 324   my ($self, $fileid, $text) = @_;
 325
 326   my ($file) = grep $_->{name} eq $fileid, @{$self->{files}}
 327     or return "** unknown file $fileid **";
 328
 329   my $title = defined $text ? $text : $file->{displayName};
 330   if ($file->{forSale}) {
 331     return escape_html($title);
 332   }
 333   else {
 334     my $url = "/cgi-bin/user.pl?download_file=1&file=$file->{id}";
 335     return qq!<a href="! . escape_html($url) . qq!">! .
 336       escape_html($title) . "</a>";
 337   }
 338 }
 339
 340 sub replace {
 341   my ($self, $rpart) = @_;
 342
 343   $$rpart =~ s#gimage\[([^\]\[]+)\]# $self->gimage($1) #ige
 344     and return 1;
 345   $$rpart =~ s#popdoclink\[(\w+)\|([^\]\[]+)\]# $self->doclink($1, $2, "_blank", 'popdoclink') #ige
 346     and return 1;
 347   $$rpart =~ s#popdoclink\[(\w+)\]# $self->doclink($1, undef, "_blank", 'popdoclink') #ige
 348     and return 1;
 349   $$rpart =~ s#doclink\[(\w+)\|([^\]\[]+)\]# $self->doclink($1, $2, undef, 'doclink') #ige
 350     and return 1;
 351   $$rpart =~ s#doclink\[(\w+)\]# $self->doclink($1,  undef, undef, 'doclink') #ige
 352     and return 1;
 353
 354   $$rpart =~ s#popformlink\[(\w+)\|([^\]\[]+)\]#
 355     $self->formlink($1, 'popformlink', $2, '_blank') #ige
 356     and return 1;
 357   $$rpart =~ s#popformlink\[(\w+)\]#
 358     $self->formlink($1, 'popformlink', undef, '_blank') #ige
 359     and return 1;
 360   $$rpart =~ s#formlink\[(\w+)\|([^\]\[]+)\]#
 361     $self->formlink($1, 'formlink', $2) #ige
 362     and return 1;
 363   $$rpart =~ s#formlink\[(\w+)\]# $self->formlink($1, 'formlink', undef) #ige
 364     and return 1;
 365   $$rpart =~ s#filelink\[\s*(\w+)\s*\|([^\]\[]+)\]# $self->filelink($1, $2) #ige
 366       and return 1;
 367   $$rpart =~ s#filelink\[\s*(\w+)\s*\]# $self->filelink($1) #ige
 368       and return 1;
 369   $$rpart =~ s#popimage\[([^\[\]]+)\]# $self->popimage($1) #ige
 370     and return 1;
 371
 372   return $self->SUPER::replace($rpart);
 373 }
 374
 375 sub formlink {
 376   my ($self, $id, $type, $text, $target) = @_;
 377
 378   my $cfg = $self->{gen}{cfg};
 379   my $section = "$id form";
 380   my $title = escape_html($cfg->entry($section, 'title', "Send us a comment"));
 381   $text ||= $title;
 382   my $secure = $cfg->entry($section, 'secure', 0);
 383   my $abs_url = $self->{abs_urls} || $secure;
 384
 385   my $prefix = '';
 386   if ($abs_url) {
 387     $prefix = $cfg->entryVar('site', $secure ? 'secureurl' : 'url');
 388   }
 389
 390   my $extras = '';
 391   if ($type) {
 392     my $class = $self->tag_class($type);
 393     if ($class) {
 394       $extras .= qq/ class="$class"/;
 395     }
 396   }
 397   if ($target) {
 398     $extras .= qq/ target="$target"/;
 399   }
 400
 401   return qq!<a href="$prefix/cgi-bin/fmail.pl?form=$id" title="$title"$extras>$text</a>!;
 402 }
 403
 404 sub remove_doclink {
 405   my ($self, $id) = @_;
 406
 407   my $error;
 408   my $art = $self->_get_article ($id, \$error)
 409     or return $error;
 410
 411   return $art->{title};
 412 }
 413
 414 sub remove_formlink {
 415   my ($self, $id) = @_;
 416
 417   return $self->{gen}{cfg}->entry("$id form", 'title', "Send us a comment");
 418 }
 419
 420 sub remove_popimage {
 421   my ($self, $args) = @_;
 422
 423   my ($image1, $image2, $align, $style) = split /\|/, $args;
 424
 425   my $images = $self->{images};
 426   if ($image1 =~ /^\d+$/) { # image index
 427     if ($image1 >= 1 and $image1 <= @$images) {
 428       return $images->[$image1-1]{alt};
 429     }
 430   }
 431   elsif ($image1 =~ /^\w+$/) { # image name
 432     my ($image) = grep $_->{name} eq $image1, @$images;
 433     return $image ? $image->{alt} : '';
 434   }
 435   else {
 436     return $image1;
 437   }
 438 }
 439
 440 sub remove_filelink {
 441   my ($self, $fileid, $text) = @_;
 442
 443   my ($file) = grep $_->{name} eq $fileid, @{$self->{files}}
 444     or return "** unknown file $fileid **";
 445
 446   return defined $text ? $text : $file->{displayName};
 447 }
 448
 449 sub remove {
 450   my ($self, $rpart) = @_;
 451
 452   $$rpart =~ s#gimage\[([^\]\[]+)\]##ig
 453     and return 1;
 454   $$rpart =~ s#popdoclink\[(\w+)\|([^\]\[]*)\]#$2#ig
 455     and return 1;
 456   $$rpart =~ s#popdoclink\[(\w+)\]# $self->remove_doclink($1) #ige
 457     and return 1;
 458   $$rpart =~ s#doclink\[(\w+)\|([^\]\[]*)\]#$2#ig
 459     and return 1;
 460   $$rpart =~ s#doclink\[(\w+)\]# $self->remove_doclink($1) #ige
 461     and return 1;
 462
 463   $$rpart =~ s#popformlink\[(\w+)\|([^\]\[]*)\]#$2#ig
 464     and return 1;
 465   $$rpart =~ s#popformlink\[(\w+)\]# $self->remove_formlink($1) #ige
 466     and return 1;
 467
 468   $$rpart =~ s#filelink\[\s*(\w+)\s*\|([^\]\[]+)\]# $self->remove_filelink($1, $2) #ige
 469       and return 1;
 470   $$rpart =~ s#filelink\[\s*(\w+)\s*\]# $self->remove_filelink($1) #ige
 471       and return 1;
 472
 473   $$rpart =~ s#formlink\[(\w+)\|([^\]\[]*)\]#$2#ig
 474     and return 1;
 475   $$rpart =~ s#formlink\[(\w+)\]# $self->remove_formlink($1) #ige
 476     and return 1;
 477   $$rpart =~ s#popimage\[([^\[\]]+)\]# $self->remove_popimage($1) #ige
 478     and return 1;
 479
 480 }
 481
 482 sub tag_class {
 483   my ($self, $type) = @_;
 484
 485   my $default = $type eq 'p' ? '' : $type;
 486
 487   return $self->{gen}{cfg}->entry('body class', $type, $default);
 488 }
 489
 490 1;