X-Git-Url: https://git.p6c8.net/selfforum.git/blobdiff_plain/504ff3f8ee5e277c2b1bf12a7a630098eaf55f0a..ba659b53059e637777865e646f0f2a6fb7f2988e:/selfforum-cgi/shared/Encode/Posting.pm

diff --git a/selfforum-cgi/shared/Encode/Posting.pm b/selfforum-cgi/shared/Encode/Posting.pm
new file mode 100644
index 0000000..b12420f
--- /dev/null
+++ b/selfforum-cgi/shared/Encode/Posting.pm
@@ -0,0 +1,231 @@
+# Posting.pm
+
+# ====================================================
+# Autor: n.d.p. / 2001-01-07
+# lm   : n.d.p. / 2001-01-08
+# ====================================================
+# Funktion:
+#      Spezielle Codierung eines Postingtextes
+# ====================================================
+
+use strict;
+
+package Encode::Posting;
+
+use vars qw(@ISA @EXPORT);
+use Encode::Plain; $Encode::Plain::utf8 = 1;
+
+# ====================================================
+# Funktionsexport
+# ====================================================
+
+require Exporter;
+@ISA    = qw(Exporter);
+@EXPORT = qw(encoded_body answer_field message_field);
+
+################################
+# sub encoded_body
+#
+# Nachrichtentext in gueltiges
+# HTML konvertieren
+################################
+
+sub encoded_body ($;$) {
+  my $posting = ${+shift};
+  my $params = shift;
+
+  $posting =~ s/[ \t]$//gm;        # Whitespaces am Zeilenende entfernen
+  $posting =~s /\s+$//;            # Whitespaces am Stringende entfernen
+  $posting = ${plain (\$posting)}; # Sonderzeichen maskieren
+
+  # Quotingzeichen normalisieren (\177)
+  my $quote = plain($params -> {quoteChars});
+  my $qquote = quotemeta $quote;
+  my $len = length ($quote);
+  $posting =~ s!^((?:$qquote)+)(.*)$!"\177" x (length($1)/$len) .$2!gem if (length ($qquote));
+
+  # Multine
+  $posting = ${multiline (\$posting)};
+
+  # normaler Link
+  $posting =~ s{\[link:\s*
+               ((?:ftp://                        # hier beginnt $1
+               |   https?://
+               |   about:
+               |   view-source:
+               |   gopher://
+               |   mailto:
+               |   news:
+               |   nntp://
+               |   telnet://
+               |   wais://
+               |   prospero://
+               |   \.\.?/                        # relativ auf dem server
+               |   /                             # absolut auf dem server
+               |   (?:[a-zA-Z.\d]+)?\??          # im forum
+               )   [^\s<'()\[\]]+                # auf jeden Fall kein \s und kein ] etc.
+               )                                 # hier ist $1 zuende
+               \s*(?:\]|(\s|\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
+              }
+              {<a href="$1">$1</a>$2}gix;        # und der Link
+
+  # javascript-links extra
+  my $klammer1='\((?:[^)])*\)';
+  my $klammer2="\\((?:$klammer1|(?:[^)])*)\\)";
+  my $klammer3="\\((?:$klammer2|(?:[^)])*)\\)";
+  my $klammer4="\\((?:$klammer3|(?:[^)])*)\\)";
+
+  $posting =~ s{\[link:\s*
+               (javascript:                      # hier beginnt $1
+               (?:
+                 $klammer4                       # Klammern bis Verschachtelungstiefe 4 (sollte reichen?)
+               | '[^\'\\]*(?:\\.[^\'\\]*)*'      # mit ' quotierter String, J.F. sei gedankt
+                                                 # im String sind Escapes zugelassen (also auch \')
+                                                 # damit werden (korrekt gesetzte) Javascript-Links moeglich
+               | [^\s<()'\]]+)+                  # auf jeden Fall kein \s und kein ] (ausser im String)
+               )                                 # hier ist $1 zuende
+               \s*(?:\s|\]|(\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
+              }
+              {<a href="$1">$1</a>$2}gix;        # und der Link
+
+  # images
+  $posting =~ s{\[image:\s*
+               ((?:https?://
+               |   \.\.?/                        # relativ auf dem server
+               |   /                             # absolut auf dem server
+               |   (?:[a-zA-Z.\d]+)?\??          # im forum
+               )   [^\s<'()\[\]]+                # auf jeden Fall kein \s und kein ] etc.
+               )                                 # hier ist $1 zuende
+               \s*(?:\]|(\s|\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
+              }
+              {<img src="$1" border=0 alt="">$2}gix; # und das Bild
+
+  # iframe
+  $posting =~ s{\[iframe:\s*
+               ((?:ftp://
+               |   https?://
+               |   about:
+               |   view-source:
+               |   gopher://
+               |   mailto:
+               |   news:
+               |   nntp://
+               |   telnet://
+               |   wais://
+               |   prospero://
+               |   \.\.?/                        # relativ auf dem server
+               |   /                             # absolut auf dem server
+               |   [a-zA-Z\d]+(?:\.html?|/)      # im forum (koennen eh nur threads oder verweise
+                                                 # auf tiefere verzeichnisse sein)
+               )[^\s<'()\]]+                     # auf jeden Fall kein \s und kein ] etc. (s.o.)
+               )                                 # hier ist $1 zuende
+               \s*(?:\]|(\s|\(|\)|<br>))         # der Begrenzer (\s, ] oder Zeilenende)
+              }
+              {<iframe src="$1" width="90%" height="90%"><a href="$1">$1</a></iframe>$2}gix;
+
+  # [msg...]
+  $params -> {messages} = {} unless (defined $params -> {messages});
+  my %msg = %{$params -> {messages}};
+  foreach (keys %msg) {
+    $posting =~ s/\[msg:\s*$_(?:\s*\]|\s)/'<img src="'.$msg{$_} -> {src}.'" width='.$msg{$_}->{width}.' height='.$msg{$_}->{height}.' border=0 alt="'.plain($msg{$_}->{alt}).'">'/gei;}
+
+  # Rueckgabe
+  \$posting;
+}
+
+################################
+# sub answer_field
+#
+# Antwort HTML einer Message
+# erzeugen
+################################
+
+sub answer_field ($$) {
+  my $posting = shift;
+  my $params = shift;
+  $params = {} unless (defined $params);
+
+  # ================
+  # Antwortfeld
+  # ================
+  my $area = $$posting;
+
+  my $qchar = $params -> {quoteChars};
+
+  $area =~ s/(?:^|(<br>))(?!<br>)/$1\177/g if ($params -> {quoteArea}); # Antwortfeld quoten?!
+  $area =~ s/\177/$qchar/g; # normalisierte Quotes jedenfalls in Chars umsetzen
+
+  # HTML-Zeug zurueckuebersetzen
+
+  $params -> {messages} = {} unless (defined $params -> {messages}); # um Fehlermeldungen auszuschliessen...
+  my %msg = map {($params -> {messages} -> {$_} -> {src} => $_)} keys %{$params -> {messages}};
+
+  $area =~ s{<iframe\s+src="([^"]*)"[^>]+>.*?</iframe>|<img\s+src="([^"]*)"\s+width[^>]+>|<img src="([^"]*)"[^>]*>|<a href="([^"]*)">.*?</a>}
+            {if    (defined $1) {"[iframe: $1]"}
+             elsif (defined $2) {"[msg: $msg{$2}]"}
+             elsif (defined $3) {"[image: $3]"}
+             elsif (defined $4) {"[link: $4]"}}eg;
+  $area =~ s/<br>/\n/g;
+  $area =~ s/&(?:#160|nbsp);/ /g;
+
+  # Rueckgabe
+  \$area;
+}
+
+################################
+# sub message_field
+#
+# HTML eines Postingtextes
+# erzeugen
+################################
+
+sub message_field ($$) {
+  my $posting = ${+shift};
+  my $params = shift;
+  $params = {} unless (defined $params);
+
+  # ================
+  # Postingtext
+  # ================
+  my $qchar = $params -> {quoteChars};
+
+  if ($params -> {quoting}) {    # Quotes bekommen eine extra Klasse?
+    # ueberfluessige Abstaende entfernen,
+    # sie werden eh wieder auseinandergezogen...
+    $posting =~ s/(\177(?:[^<]|<(?!br>))*<br>)<br>(?=\177)/$1/g;
+    $posting =~ s/(\177(?:[^<]|<(?!br>))*<br>)<br>(?!\177)/$1/g;
+
+    my ($last_level, $level, $line, $q, @new)=(-1,0);
+
+    foreach $line (split (/<br>/,$posting)) { # Zeilenweise gucken,
+      ($q) = ($line =~ /^(\177+)/g);          # wieviele
+      $level = length ($q);                   # Quotingchars am Anfang stehen
+      if ($level != $last_level) {            # wenn sich was verandert...
+                                              # ... dann TU ETWAS!
+
+        if    ($last_level <= 0 and $level > 0) {$last_level = $level; $line='<br>'.$params -> {startCite} . $line}
+        elsif ($level > 0) {$last_level = $level; $line=$params -> {endCite} . '<br>' . $params -> {startCite} . $line}
+        elsif ($level == 0 and $last_level > 0) {$last_level = -1; $line = $params -> {endCite} . '<br>' . $line}}
+
+      push @new,$line}
+
+    $new[0] =~ s/^<br>//;
+    $posting = (join '<br>',@new) . (($last_level > 0)?$params -> {endCite}:'');}
+
+  $posting =~ s/\177/$qchar/g; # normalisierte Quotes in Chars umsetzen
+
+  # Rueckgabe
+  \$posting;
+}
+
+
+# ====================================================
+# Modulinitialisierung
+# ====================================================
+
+# making require happy
+1;
+
+# ====================================================
+# end of Encode::Posting
+# ====================================================
\ No newline at end of file