selfforum-cgi/shared/Encode/Posting.pm

   1 # Posting.pm
   2
   3 # ====================================================
   4 # Autor: n.d.p. / 2001-01-07
   5 # lm   : n.d.p. / 2001-02-25
   6 # ====================================================
   7 # Funktion:
   8 #      Spezielle Codierung eines Postingtextes
   9 # ====================================================
  10
  11 use strict;
  12
  13 package Encode::Posting;
  14
  15 use vars qw(@EXPORT);
  16 use Encode::Plain; $Encode::Plain::utf8 = 1;
  17
  18 # ====================================================
  19 # Funktionsexport
  20 # ====================================================
  21
  22 use base qw(Exporter);
  23 @EXPORT = qw(encoded_body answer_field message_field);
  24
  25 ################################
  26 # sub encoded_body
  27 #
  28 # Nachrichtentext in gueltiges
  29 # HTML konvertieren
  30 ################################
  31
  32 sub encoded_body ($;$) {
  33   my $posting = ${+shift};
  34   my $params = shift;
  35
  36   $posting =~ s/[ \t]$//gm;        # Whitespaces am Zeilenende entfernen
  37   $posting =~s /\s+$//;            # Whitespaces am Stringende entfernen
  38   $posting = ${plain (\$posting)}; # Sonderzeichen maskieren
  39
  40   # Quotingzeichen normalisieren (\177)
  41   my $quote = plain($params -> {quoteChars});
  42   my $qquote = quotemeta $quote;
  43   my $len = length ($quote);
  44   $posting =~ s!^((?:$qquote)+)(.*)$!"\177" x (length($1)/$len) .$2!gem if (length ($qquote));
  45
  46   # Multine
  47   $posting = ${multiline (\$posting)};
  48
  49   # normaler Link
  50   $posting =~ s{\[link:\s*
  51                ((?:ftp://                        # hier beginnt $1
  52                |   https?://
  53                |   about:
  54                |   view-source:
  55                |   gopher://
  56                |   mailto:
  57                |   news:
  58                |   nntp://
  59                |   telnet://
  60                |   wais://
  61                |   prospero://
  62                |   \.\.?/                        # relativ auf dem server
  63                |   /                             # absolut auf dem server
  64                |   (?:[a-zA-Z.\d]+)?\??          # im forum
  65                )   [^\s<'()\[\]]+                # auf jeden Fall kein \s und kein ] etc.
  66                )                                 # hier ist $1 zuende
  67                \s*(?:\]|(\s|\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
  68               }
  69               {<a href="$1">$1</a>$2}gix;        # und der Link
  70
  71   # javascript-links extra
  72   my $klammer1='\((?:[^)])*\)';
  73   my $klammer2="\\((?:$klammer1|(?:[^)])*)\\)";
  74   my $klammer3="\\((?:$klammer2|(?:[^)])*)\\)";
  75   my $klammer4="\\((?:$klammer3|(?:[^)])*)\\)";
  76
  77   $posting =~ s{\[link:\s*
  78                (javascript:                      # hier beginnt $1
  79                (?:
  80                  $klammer4                       # Klammern bis Verschachtelungstiefe 4 (sollte reichen?)
  81                | '[^\'\\]*(?:\\.[^\'\\]*)*'      # mit ' quotierter String, J.F. sei gedankt
  82                                                  # im String sind Escapes zugelassen (also auch \')
  83                                                  # damit werden (korrekt gesetzte) Javascript-Links moeglich
  84                | [^\s<()'\]]+)+                  # auf jeden Fall kein \s und kein ] (ausser im String)
  85                )                                 # hier ist $1 zuende
  86                \s*(?:\s|\]|(\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
  87               }
  88               {<a href="$1">$1</a>$2}gix;        # und der Link
  89
  90   # images
  91   $posting =~ s{\[image:\s*
  92                ((?:https?://
  93                |   \.\.?/                        # relativ auf dem server
  94                |   /                             # absolut auf dem server
  95                |   (?:[a-zA-Z.\d]+)?\??          # im forum
  96                )   [^\s<'()\[\]]+                # auf jeden Fall kein \s und kein ] etc.
  97                )                                 # hier ist $1 zuende
  98                \s*(?:\]|(\s|\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
  99               }
 100               {<img src="$1" border=0 alt="">$2}gix; # und das Bild
 101
 102   # iframe
 103   $posting =~ s{\[iframe:\s*
 104                ((?:ftp://
 105                |   https?://
 106                |   about:
 107                |   view-source:
 108                |   gopher://
 109                |   mailto:
 110                |   news:
 111                |   nntp://
 112                |   telnet://
 113                |   wais://
 114                |   prospero://
 115                |   \.\.?/                        # relativ auf dem server
 116                |   /                             # absolut auf dem server
 117                |   [a-zA-Z\d]+(?:\.html?|/)      # im forum (koennen eh nur threads oder verweise
 118                                                  # auf tiefere verzeichnisse sein)
 119                )[^\s<'()\]]+                     # auf jeden Fall kein \s und kein ] etc. (s.o.)
 120                )                                 # hier ist $1 zuende
 121                \s*(?:\]|(\s|\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
 122               }
 123               {<iframe src="$1" width="90%" height="90%"><a href="$1">$1</a></iframe>$2}gix;
 124
 125   # [msg...]
 126   $params -> {messages} = {} unless (defined $params -> {messages});
 127   my %msg = %{$params -> {messages}};
 128   foreach (keys %msg) {
 129     $posting =~ s/\[msg:\s*$_(?:\s*\]|\s)/'<img src="'.$msg{$_} -> {src}.'" width='.$msg{$_}->{width}.' height='.$msg{$_}->{height}.' border=0 alt="'.plain($msg{$_}->{alt}).'">'/gei;}
 130
 131   # Rueckgabe
 132   \$posting;
 133 }
 134
 135 ################################
 136 # sub answer_field
 137 #
 138 # Antwort HTML einer Message
 139 # erzeugen
 140 ################################
 141
 142 sub answer_field ($$) {
 143   my $posting = shift;
 144   my $params = shift;
 145   $params = {} unless (defined $params);
 146
 147   # ================
 148   # Antwortfeld
 149   # ================
 150   my $area = $$posting;
 151
 152   my $qchar = $params -> {quoteChars};
 153
 154   $area =~ s/(?:^|(<br>))(?!<br>)/$1\177/g if ($params -> {quoteArea}); # Antwortfeld quoten?!
 155   $area =~ s/\177/$qchar/g; # normalisierte Quotes jedenfalls in Chars umsetzen
 156
 157   # HTML-Zeug zurueckuebersetzen
 158
 159   $params -> {messages} = {} unless (defined $params -> {messages}); # um Fehlermeldungen auszuschliessen...
 160   my %msg = map {($params -> {messages} -> {$_} -> {src} => $_)} keys %{$params -> {messages}};
 161
 162   $area =~ s{<iframe\s+src="([^"]*)"[^>]+>.*?</iframe>|<img\s+src="([^"]*)"\s+width[^>]+>|<img src="([^"]*)"[^>]*>|<a href="([^"]*)">.*?</a>}
 163             {if    (defined $1) {"[iframe: $1]"}
 164              elsif (defined $2) {"[msg: $msg{$2}]"}
 165              elsif (defined $3) {"[image: $3]"}
 166              elsif (defined $4) {"[link: $4]"}}eg;
 167   $area =~ s/<br>/\n/g;
 168   $area =~ s/&(?:#160|nbsp);/ /g;
 169
 170   # Rueckgabe
 171   \$area;
 172 }
 173
 174 ################################
 175 # sub message_field
 176 #
 177 # HTML eines Postingtextes
 178 # erzeugen
 179 ################################
 180
 181 sub message_field ($$) {
 182   my $posting = ${+shift};
 183   my $params = shift;
 184   $params = {} unless (defined $params);
 185
 186   # ================
 187   # Postingtext
 188   # ================
 189   my $qchar = $params -> {quoteChars};
 190
 191   if ($params -> {quoting}) {    # Quotes bekommen eine extra Klasse?
 192     # ueberfluessige Abstaende entfernen,
 193     # sie werden eh wieder auseinandergezogen...
 194     $posting =~ s/(\177(?:[^<]|<(?!br>))*<br>)<br>(?=\177)/$1/g;
 195     $posting =~ s/(\177(?:[^<]|<(?!br>))*<br>)<br>(?!\177)/$1/g;
 196
 197     my ($last_level, $level, $line, $q, @new)=(-1,0);
 198
 199     foreach $line (split (/<br>/,$posting)) { # Zeilenweise gucken,
 200       ($q) = ($line =~ /^(\177+)/g);          # wieviele
 201       $level = length ($q);                   # Quotingchars am Anfang stehen
 202       if ($level != $last_level) {            # wenn sich was verandert...
 203                                               # ... dann TU ETWAS!
 204
 205         if    ($last_level <= 0 and $level > 0) {$last_level = $level; $line='<br>'.$params -> {startCite} . $line}
 206         elsif ($level > 0) {$last_level = $level; $line=$params -> {endCite} . '<br>' . $params -> {startCite} . $line}
 207         elsif ($level == 0 and $last_level > 0) {$last_level = -1; $line = $params -> {endCite} . '<br>' . $line}}
 208
 209       push @new,$line}
 210
 211     $new[0] =~ s/^<br>//;
 212     $posting = (join '<br>',@new) . (($last_level > 0)?$params -> {endCite}:'');}
 213
 214   $posting =~ s/\177/$qchar/g; # normalisierte Quotes in Chars umsetzen
 215
 216   # Rueckgabe
 217   \$posting;
 218 }
 219
 220
 221 # ====================================================
 222 # Modulinitialisierung
 223 # ====================================================
 224
 225 # making require happy
 226 1;
 227
 228 # ====================================================
 229 # end of Encode::Posting
 230 # ====================================================