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

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