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