selfforum-cgi/shared/Encode/Posting.pm

   1 package Encode::Posting;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/Encode/Posting.pm                                        #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>                                      #
   8 #                                                                              #
   9 # Description: prepare a Posting text for saving and visual (HTML) output      #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   @EXPORT
  16 );
  17
  18 use Encode::Plain; $Encode::Plain::utf8 = 1;
  19 use CheckRFC;
  20
  21 ################################################################################
  22 #
  23 # Version check
  24 #
  25 # last modified:
  26 #    $Date$ (GMT)
  27 # by $Author$
  28 #
  29 sub VERSION {(q$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'}
  30
  31 ################################################################################
  32 #
  33 # Export
  34 #
  35 use base qw(Exporter);
  36 @EXPORT = qw(
  37   encoded_body
  38   answer_field
  39   message_field
  40 );
  41
  42 ### sub rel_uri ($$) ###########################################################
  43 #
  44 # generate an absolute URI from a absolute|relative one
  45 # (not for public use)
  46 #
  47 # Params: $uri  - URI
  48 #         $base - base URI
  49 #
  50 # Return: abs URI as string
  51 #
  52 sub rel_uri ($$) {
  53   my ($uri, $base) = @_;
  54
  55   "http://$ENV{HTTP_HOST}".
  56     ($uri =~ m|^/|
  57       ? $uri
  58       : "$base$uri");
  59 }
  60
  61 ### sub encoded_body ($;$) #####################################################
  62 #
  63 # prepare posting text for saving
  64 #
  65 # Params: $posting - scalar reference of the raw text
  66 #         $params  - hash reference
  67 #                    (quoteChars messages)
  68 #
  69 # Return: scalar reference of the encoded text
  70 #
  71 sub encoded_body ($;$) {
  72   my $posting = ${+shift};
  73   my $params = shift;
  74
  75   $posting =~ s/\015\012|\015|\012/\n/g; # normalize newlines
  76   $posting =~ s/[^\S\n]+$//gm;           # kill whitespaces at the end of all lines
  77   $posting =~ s/\s+$//;                  # kill whitespaces (newlines) at the end of the string (text)
  78
  79   # check the special syntaxes:
  80
  81   my $base = $params -> {base_uri};
  82   # collect all [link:...] strings
  83   #
  84   my @rawlinks;
  85   push @rawlinks => [$1 => $2] while ($posting =~ /\[([Ll][Ii][Nn][Kk]):\s*([^\]\s]+)\s*\]/g);
  86   my @links = grep {
  87        is_URL ( $_ -> [1] => qw(http ftp news nntp telnet gopher mailto))
  88     or is_URL (($_ -> [1] =~ /^[Vv][Ii][Ee][Ww]-[Ss][Oo][Uu][Rr][Cc][Ee]:(.+)/)[0] || '' => 'http')
  89     or (  $_ -> [1] =~ m<^(?:\.?\.?/(?!/)|\?)>
  90       and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
  91   } @rawlinks;
  92
  93   # collect all [image:...] strings
  94   #
  95   my @rawimages;
  96   push @rawimages => [$1 => $2] while ($posting =~ /\[([Ii][Mm][Aa][Gg][Ee]):\s*([^\]\s]+)\s*\]/g);
  97   my @images = grep {
  98        is_URL ($_ -> [1] => 'strict_http')
  99     or (  $_ -> [1] =~ m<^(?:\.?\.?/(?!/)|\?)>
 100       and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
 101   } @rawimages;
 102
 103   # collect all [iframe:...] strings
 104   #
 105   my @rawiframes;
 106   push @rawiframes => [$1 => $2] while ($posting =~ /\[([Ii][Ff][Rr][Aa][Mm][Ee]):\s*([^\]\s]+)\s*\]/g);
 107   my @iframes = grep {
 108        is_URL ($_ -> [1] => 'http')
 109     or (  $_ -> [1] =~ m<^(?:\.?\.?/(?!/)|\?)>
 110       and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
 111   } @rawiframes;
 112
 113   # collect all [msg:...] strings
 114   #
 115   $params -> {messages} = {} unless (defined $params -> {messages});
 116   my %msg = map {lc($_) => $params -> {messages} -> {$_}} keys %{$params -> {messages}};
 117
 118   my @rawmsgs;
 119   push @rawmsgs => [$1 => $2] while ($posting =~ /\[([Mm][Ss][Gg]):\s*([^\]\s]+)\s*\]/g);
 120   my @msgs = grep {exists ($msg{lc($_ -> [1])})} @rawmsgs;
 121
 122   # encode Entities and special characters
 123   #
 124   $posting = ${plain (\$posting)};
 125
 126   # encode the special syntaxes
 127   #
 128   $posting =~ s!$_!<a href="$1">$1</a>!
 129     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @links);
 130
 131   $posting =~ s!$_!<img src="$1" border=0 alt="">!
 132     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @images);
 133
 134   $posting =~ s!$_!<iframe src="$1" width="90%" height="90%"><a href="$1">$1</a></iframe>!
 135     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @iframes);
 136
 137   %msg = map {plain($_) => $msg{$_}} keys %msg;
 138   $posting =~ s!$_!'<img src="'.$msg{lc $1} -> {src}.'" width='.$msg{lc $1}->{width}.' height='.$msg{lc $1}->{height}.' border=0 alt="'.plain($msg{lc $1}->{alt}).'">'!e
 139     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @msgs);
 140
 141   # normalize quote characters (quote => \177)
 142   #
 143   my $quote = plain(defined $params -> {quoteChars} ? $params -> {quoteChars} : '');
 144   my $len = length ($quote);
 145   $posting =~ s!^((?:\Q$quote\E)+)!"\177" x (length($1)/$len)!gem if ($len);
 146
 147   # \n => <br>, fix spaces
 148   #
 149   $posting = ${multiline (\$posting)};
 150
 151   # return
 152   #
 153   \$posting;
 154 }
 155
 156 ### sub answer_field ($$) ######################################################
 157 #
 158 # create the content of the answer textarea
 159 #
 160 # Params: $posting - scalar reference
 161 #                    (posting text, 'encoded_body' encoded)
 162 #         $params  - hash reference
 163 #                    (quoteArea quoteChars messages)
 164 #
 165 # Return: scalar reference
 166 #
 167 sub answer_field ($$) {
 168   my $posting = shift;
 169   my $params = shift || {};
 170
 171   my $area = $$posting;
 172   my $qchar = $params -> {quoteChars};
 173
 174   $area =~ s/<br(?:\s*\/)?>/\n/g;  # <br> => \n
 175   $area =~ s/&(?:#160|nbsp);/ /g;   # nbsp => ' '
 176
 177   $area =~ s/^(.)/\177$1/gm if ($params -> {quoteArea}); # shift a quoting character
 178   $area =~ s/^(\177+)/$qchar x length ($1)/gem;          # decode normalized quoting characters
 179
 180   # recode special syntaxes
 181   # from HTML to [...] constructions
 182   #
 183   $params -> {messages} = {} unless (defined $params -> {messages}); # avoid error messages
 184   my %msg = map {
 185     $params -> {messages} -> {$_} -> {src} => $_
 186   } keys %{$params -> {messages}};                                   # we have to lookup reverse ...
 187
 188   # [msg...]
 189   $area =~ s{(<img\s+src="([^"]+)"\s+width[^>]+>)} {
 190     defined $msg{$2}
 191     ? "[msg: $msg{$2}]"
 192     : $1;
 193   }ge;
 194
 195   # [iframe...]
 196   $area =~ s{<iframe\s+src="([^"]*)"[^>]+>.*?</iframe>} {[iframe: $1]}g;
 197
 198   # [image...]
 199   $area =~ s{<img src="([^"]*)"[^>]*>}{[image: $1]}g;
 200
 201   # [link...]
 202   $area =~ s{<a href="([^"]*)">.*?</a>}{[link: $1]}g;
 203
 204   # return
 205   #
 206   \$area;
 207 }
 208
 209 ### sub message_field ($$) #####################################################
 210 #
 211 # prepare the posting text for visual output
 212 #
 213 # Params: $posting - scalar reference
 214 #                    (raw posting text, 'encoded_body' encoded)
 215 #         $params  - hash reference
 216 #                    (quoteChars quoting startCite endCite)
 217 #
 218 # Return: scalar rerence (prepared posting text)
 219 #
 220 sub message_field ($$) {
 221   my $posting = ${+shift};
 222   my $params = shift || {};
 223
 224   my $break = '<br />';
 225
 226   if ($params -> {quoting}) {       # quotes are displayed as special?
 227     my @array = [0 => []];
 228
 229     for (split /<br(?:\s*\/)?>/ => $posting) {
 230       my $l = length ((/^(\177*)/)[0]);
 231       if ($array[-1][0] == $l) {
 232         push @{$array[-1][-1]} => $_;
 233       }
 234       else {
 235         push @array => [$l => [$_]];
 236       }
 237     }
 238     shift @array unless @{$array[0][-1]};
 239
 240     my $ll=0;
 241     $posting = join $break => map {
 242       my $string = $_->[0]
 243         ? (($ll and $ll != $_->[0]) ? $break : '') .
 244           join join ($break => @{$_->[-1]})
 245             => ($params->{startCite}, $params->{endCite})
 246         : (join $break => @{$_->[-1]});
 247       $ll = $_->[0]; $string;
 248     } @array;
 249   }
 250
 251   my $qchar = $params -> {quoteChars};
 252   $posting =~ s/\177/$qchar/g; # \177 => quote chars
 253
 254   # return
 255   #
 256   \$posting;
 257 }
 258
 259 # keep 'require' happy
 260 1;
 261
 262 #
 263 #
 264 ### end of Encode::Posting #####################################################