CMS/Simple/Filter/Markup.pm

   1
   2 package CMS::Simple::Filter::Markup ;
   3
   4 use strict ;
   5 use warnings ;
   6
   7 my %markup_to_code = (
   8
   9         l       => \&make_link,
  10         link    => \&make_link,
  11         email   => \&make_email,
  12         image   => \&make_image,
  13         image_link      => \&make_image_link,
  14         ilink   => \&make_image_link,
  15         nbsp    => sub { '&nbsp;' },
  16         em_dash => sub { '&#151;' },
  17         eacute  => sub { '&#233;' },
  18         copy    => sub { '&#169;' },
  19         p       => sub { '<p>' },
  20         br      => sub { '<br/>' },
  21         gmap    => \&google_map,
  22 ) ;
  23
  24 sub filter_markup {
  25
  26         my( $tag, $text ) = @_ ;
  27
  28 #print "TEXT $text\n" ;
  29
  30         return unless $text =~
  31                         s{(?<!\\)\[([a-z_]+)(?:\s+([^]]+)\s*)?\]}
  32                          {replace_markup(lc $1, $2)}gie
  33                         ||
  34                         $text =~ s{\\\[}{[}g ;
  35
  36         return $text ;
  37 }
  38
  39 sub replace_markup {
  40
  41         my( $key, $text ) = @_ ;
  42
  43 #print "KEY $key [$text]\n" ;
  44
  45         my $code = $markup_to_code{ $key } ;
  46
  47         $code or die "unknown markup key '$key'" ;
  48
  49         return $code->($text) ;
  50 }
  51
  52 sub make_link {
  53
  54         my( $text ) = @_ ;
  55
  56         my( $url, $url_text ) = split /\|/, $text ;
  57
  58         $url_text ||= $url ;
  59
  60         return qq{<A href="$url">$url_text</A>} ;
  61 }
  62
  63 sub google_map {
  64
  65         my( $text ) = @_ ;
  66
  67         ( my $url_text = $text ) =~ tr/ \t\n\r/+/s ;
  68
  69         return
  70 qq{<A href="http://maps.google.com/maps?f=q&hl=en&q=$url_text">$text</A>} ;
  71 }
  72
  73 sub make_email {
  74
  75         my( $text ) = @_ ;
  76
  77         my( $user, $domain ) = split /\@/, $text ;
  78
  79         return <<EMAIL ;
  80 <script>
  81 document.write('<a href="mailto:$user' + '\@' +
  82           '$domain">$user AT $domain</a>')
  83 </script>
  84 <noscript>
  85 $user AT $domain
  86 </noscript>
  87 EMAIL
  88
  89 }
  90
  91 sub make_image_link {
  92
  93         my( $text ) = @_ ;
  94
  95         my( $url, $image_url ) = split /\|/, $text ;
  96
  97         return qq{<A href="$url"><IMG src="$image_url"></A>} ;
  98 }
  99
 100 sub make_image {
 101
 102         my( $text ) = @_ ;
 103
 104         return qq{<IMG src="$text">} ;
 105 }