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