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