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 (  $_ -> [1] =~ m<^(?:\.?\.?/(?!/)|\?)>
  97       and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
  98   } @rawiframes;
  99
 100   # collect all [msg:...] strings
 101   #
 102   $params -> {messages} = {} unless (defined $params -> {messages});
 103   my %msg = map {lc($_) => $params -> {messages} -> {$_}} keys %{$params -> {messages}};
 104
 105   my @rawmsgs;
 106   push @rawmsgs => [$1 => $2] while ($posting =~ /\[([Mm][Ss][Gg]):\s*([^\]\s]+)\s*\]/g);
 107   my @msgs = grep {exists ($msg{lc($_ -> [1])})} @rawmsgs;
 108
 109   # encode Entities and special characters
 110   #
 111   $posting = ${plain (\$posting)};
 112
 113   # encode the special syntaxes
 114   #
 115   $posting =~ s!$_!<a href="$1">$1</a>!
 116     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @links);
 117
 118   $posting =~ s!$_!<img src="$1" border=0 alt="">!
 119     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @images);
 120
 121   $posting =~ s!$_!<iframe src="$1" width="90%" height="90%"><a href="$1">$1</a></iframe>!
 122     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @iframes);
 123
 124   %msg = map {plain($_) => $msg{$_}} keys %msg;
 125   $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
 126     for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @msgs);
 127
 128   # normalize quote characters (quote => \177)
 129   #
 130   my $quote = plain(defined $params -> {quoteChars} ? $params -> {quoteChars} : '');
 131   my $len = length ($quote);
 132   $posting =~ s!^((?:\Q$quote\E)+)!"\177" x (length($1)/$len)!gem if ($len);
 133
 134   # \n => <br>, fix spaces
 135   #
 136   $posting = ${multiline (\$posting)};
 137
 138   # return
 139   #
 140   \$posting;
 141 }
 142
 143 ### sub answer_field ($$) ######################################################
 144 #
 145 # create the content of the answer textarea
 146 #
 147 # Params: $posting - scalar reference
 148 #                    (posting text, 'encoded_body' encoded)
 149 #         $params  - hash reference
 150 #                    (quoteArea quoteChars messages)
 151 #
 152 # Return: scalar reference
 153 #
 154 sub answer_field ($$) {
 155   my $posting = shift;
 156   my $params = shift || {};
 157
 158   my $area = $$posting;
 159   my $qchar = $params -> {quoteChars};
 160
 161   $area =~ s/<br(?:\/| \/)?>/\n/g;  # <br> => \n
 162   $area =~ s/&(?:#160|nbsp);/ /g;   # nbsp => ' '
 163
 164   $area =~ s/^(.)/\177$1/gm if ($params -> {quoteArea}); # shift a quoting character
 165   $area =~ s/^(\177+)/$qchar x length ($1)/gem;          # decode normalized quoting characters
 166
 167   # recode special syntaxes
 168   # from HTML to [...] constructions
 169   #
 170   $params -> {messages} = {} unless (defined $params -> {messages}); # avoid error messages
 171   my %msg = map {
 172     $params -> {messages} -> {$_} -> {src} => $_
 173   } keys %{$params -> {messages}};                                   # we have to lookup reverse ...
 174
 175   # [msg...]
 176   $area =~ s{(<img\s+src="([^"]+)"\s+width[^>]+>)} {
 177     defined $msg{$2}
 178     ? "[msg: $msg{$2}]"
 179     : $1;
 180   }ge;
 181
 182   # [iframe...]
 183   $area =~ s{<iframe\s+src="([^"]*)"[^>]+>.*?</iframe>} {[iframe: $1]}g;
 184
 185   # [image...]
 186   $area =~ s{<img src="([^"]*)"[^>]*>}{[image: $1]}g;
 187
 188   # [link...]
 189   $area =~ s{<a href="([^"]*)">.*?</a>}{[link: $1]}g;
 190
 191   # return
 192   #
 193   \$area;
 194 }
 195
 196 ### sub message_field ($$) #####################################################
 197 #
 198 # prepare the posting text for visual output
 199 #
 200 # Params: $posting - scalar reference
 201 #                    (raw posting text, 'encoded_body' encoded)
 202 #         $params  - hash reference
 203 #                    (quoteChars quoting startCite endCite)
 204 #
 205 # Return: scalar rerence (prepared posting text)
 206 #
 207 sub message_field ($$) {
 208   my $posting = ${+shift};
 209   my $params = shift || {};
 210
 211   my $break = '<br />';
 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     my $ll=0;
 228     $posting = join $break => map {
 229       my $string = $_->[0]
 230         ? (($ll and $ll != $_->[0]) ? $break : '') .
 231           join join ($break => @{$_->[-1]})
 232             => ($params->{startCite}, $params->{endCite})
 233         : (join $break => @{$_->[-1]});
 234       $ll = $_->[0]; $string;
 235     } @array;
 236   }
 237
 238   my $qchar = $params -> {quoteChars};
 239   $posting =~ s/\177/$qchar/g; # \177 => quote chars
 240
 241   # return
 242   #
 243   \$posting;
 244 }
 245
 246 # keeping 'require' happy
 247 1;
 248
 249 #
 250 #
 251 ### end of Encode::Posting #####################################################