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