# #
# File: shared/CheckRFC.pm #
# #
-# Authors: Andre Malo <nd@o3media.de>, 2001-03-30 #
+# Authors: Andre Malo <nd@o3media.de>, 2001-04-14 #
# #
# Description: implement several string checks on RFC correctness #
# #
################################################################################
use strict;
-use vars qw(%url $email @EXPORT);
+use vars qw(
+ $v56
+ %url
+ @email
+ @EXPORT
+ @ISA
+);
-use autouse 'Carp' => qw(croak);
+$v56 = eval q[
+ local $SIG{__DIE__};
+ require 5.6.0;
+];
+
+use Carp qw(croak);
################################################################################
#
# Export
#
-use base qw(Exporter);
-@EXPORT = qw(is_URL is_email);
+require Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ is_URL
+ is_email
+);
### is_URL ($@) ################################################################
#
#
# Params: $string string to check
# @schemes possible URL schemes in $string
-# qw(http ftp news nntp telnet gopher wais mailto file prospero)
+# qw( http strict_http ftp news nntp telnet
+# gopher wais mailto strict_mailto file prospero)
# if there's no scheme given, 'http' is default
# use ':ALL' (without quotes) for all schemes
#
#
sub is_URL ($@) {
my ($string, @schemes) = @_;
+
+ return unless (defined ($string) and length ($string));
+
@schemes = qw(http) unless (@schemes);
@schemes = keys %url if (@schemes == 1 and $schemes[0] eq ':ALL');
for (@schemes) {
croak "unknown url scheme '$_'" unless exists $url{$_};
- return 1 if $string =~ /$url{$_}/;
+ unless (/mailto/) {
+ return 1 if ($string =~ /$url{$_}/);
+ }
+ else {
+ return unless ($string =~ /^mailto:(.+)/);
+
+ if ($_ eq 'mailto') {
+ return 1 if (is_email ($1));
+ }
+ elsif ($_ eq 'strict_mailto') {
+ return 1 if (is_email ($1,1));
+ }
+ }
}
# no match => return false
#
# check email (comments can be nested)
#
-# Params: $string string to check
+# Params: $string - string to check
+# $strict - (optional) check strict RFC syntax (no TLD needed) if true
#
# Return: Status code (Bool)
#
-sub is_email ($) {
+sub is_email ($;$) {
my $string = shift;
+ my $strict = shift;
# false if any non-ascii chars
+ return unless (defined ($string) and length ($string));
return if $string =~ /[\200-\377]/;
# remove nested comments
- while ($string =~ s/\([^()]*\)//g) {};
+ 1 while ($string =~ s/\([^()]*\)//g);
+
+ return ($string =~ /^$email[0]$/) unless $strict;
- return ($string =~ /^$email$/);
+ return ($string =~ /^$email[1]$/);
}
### BEGIN # (1) ################################################################
BEGIN {
# Thanx to J. Friedl:
- my $esc = '\\\\';
+ my $esc = '\\\\';
my $Period = '\.';
- my $space = '\040';
+ my $space = '\040';
my $tab = '\t';
- my $OpenBR = '\[';
+ my $OpenBR = '\[';
my $CloseBR = '\]';
- my $OpenParen = '\(';
+ my $OpenParen = '\(';
my $CloseParen = '\)';
- my $NonASCII = '\x80-\xff';
+ my $NonASCII = '\x80-\xff';
my $ctrl = '\000-\037';
- my $CRlist = '\n\015';
- my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
- my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
+ my $CRlist = '\n\015';
+ my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
+ my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
my $quoted_pair = qq< $esc [^$NonASCII] >;
- my $ctext = qq< [^$esc$NonASCII$CRlist()] >;
- my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
- my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
- my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
+ my $ctext = qq< [^$esc$NonASCII$CRlist()] >;
+ my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
+ my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
+ my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
- my $atom = qq< $atom_char+ (?!$atom_char) >;
- my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
- my $word = qq< (?: $atom | $quoted_str ) >;
+ my $atom = qq< $atom_char+ (?!$atom_char) >;
+ my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
+ my $word = qq< (?: $atom | $quoted_str ) >;
my $domain_ref = $atom;
my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
my $sub_domain = qq< (?: $domain_ref | $domain_lit ) $X >;
- my $domain = qq< $sub_domain (?: $Period $X $sub_domain )* >;
- my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
- my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
- my $addr_spec = qq< $local_part \@ $X $domain >;
- my $route_addr = qq[ < $X (?: $route )? $addr_spec > ];
- my $phrase_ctrl = '\000-\010\012-\037';
- my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
- my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
- $email = qq< $X (?: $addr_spec | $phrase $route_addr ) >;
- $email = qr /$email/x;
+ my $domain;
+
+ @email = ();
+ for $domain (
+ qq< $sub_domain (?: $Period $X $sub_domain )+ >,
+ qq< $sub_domain (?: $Period $X $sub_domain )* >
+ ) {
+ my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
+ my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
+ my $addr_spec = qq< $local_part \@ $X $domain >;
+ my $route_addr = qq[ < $X (?: $route )? $addr_spec > ];
+ my $phrase_ctrl = '\000-\010\012-\037';
+ my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
+ my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
+ my $email = qq< $X (?: $addr_spec | $phrase $route_addr ) >;
+
+ if ($v56) {
+ eval q<
+ local $SIG{__DIE__};
+ $email = qr/$email/x;
+ >;
+ }
+ else {
+ $email =~ s/\s+//g;
+ }
+
+ push @email => $email;
+ }
}
### BEGIN # (2) ################################################################
my $password = "(?:(?:$uchar|[;?&=])*)";
my $port = '(?:[0-5]?\d\d?\d?\d?|6[0-4]\d\d\d|65[0-4]\d\d|655[0-2]\d|6553[0-5])';
my $ip4part = '(?:[01]?\d\d?|2[0-4]\d|25[0-5])';
- my $hostnumber = '(?:(?!0+\.0+\.0+\.0+)'."$ip4part\\.$ip4part\\.$ip4part\\.$ip4part)";
+ my $hostnumber = '(?:(?!0+\.0+\.0+\.0+)(?!255\.255\.255\.255)'."$ip4part\\.$ip4part\\.$ip4part\\.$ip4part)";
my $toplabel = "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
my $domainlabel = "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
my $hostname = "(?:(?:$domainlabel\\.)*$toplabel)";
my $search = "(?:(?:$httpuchar|[;:\@&=~])*)";
my $hpath = "(?:$hsegment(?:/$hsegment)*)";
my $httpurl = "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?(?:#$xchar*)?)";
+ my $strict_httpurl = "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?)";
# GOPHER (see also RFC1436)
my $gopher_plus = "(?:$xchar*)";
my $gtype = "(?:$xchar)";
my $gopherurl = "(?:gopher://$hostport(?:/$gtype(?:$selector(?:%09$search(?:%09$gopher_plus)?)?)?)?)";
- # MAILTO (see also RFC822)
- my $encoded822addr = "(?:$email)";
- my $mailtourl = "(?:mailto:$encoded822addr)";
-
# NEWS (see also RFC1036)
my $article = "(?:(?:$uchar|[;/?:&=])+\@$host)";
my $group = "(?:$alpha(?:$alpha|$digit|[.+_-])*)";
my $ppath = "(?:$psegment(?:/$psegment)*)";
my $prosperourl = "(?:prospero://$hostport/$ppath(?:$fieldspec)*)";
- %url = (
- http => qr/^$httpurl$/,
- ftp => qr/^$ftpurl$/,
- news => qr/^$newsurl$/,
- nntp => qr/^$nntpurl$/,
- telnet => qr/^$telneturl$/,
- gopher => qr/^$gopherurl$/,
- wais => qr/^$waisurl$/,
- mailto => qr/^$mailtourl$/,
- file => qr/^$fileurl$/,
- prospero => qr/^$prosperourl$/
- );
+ if ($v56) {
+ eval q[%url = (
+ http => qr/^$httpurl$/,
+ strict_http => qr/^$strict_httpurl$/,
+ ftp => qr/^$ftpurl$/,
+ news => qr/^$newsurl$/,
+ nntp => qr/^$nntpurl$/,
+ telnet => qr/^$telneturl$/,
+ gopher => qr/^$gopherurl$/,
+ wais => qr/^$waisurl$/,
+ mailto => 0,
+ strict_mailto => 0,
+ file => qr/^$fileurl$/,
+ prospero => qr/^$prosperourl$/
+ );];
+ }
+ else {
+ %url = (
+ http => "^$httpurl\$",
+ strict_http => "^$strict_httpurl\$",
+ ftp => "^$ftpurl\$",
+ news => "^$newsurl\$",
+ nntp => "^$nntpurl\$",
+ telnet => "^$telneturl\$",
+ gopher => "^$gopherurl\$",
+ wais => "^$waisurl\$",
+ mailto => 0,
+ strict_mailto => 0,
+ file => "^$fileurl\$",
+ prospero => "^$prosperourl\$"
+ );
+ }
}
# keeping require happy
-# Encode/Plain.pm
-
-# ====================================================
-# Autor: n.d.p. / 2001-01-07
-# lm : n.d.p. / 2001-02-25
-# ====================================================
-# Funktion:
-# Codierung von non-ASCII-Zeichen fuer
-# HTML
-# ====================================================
-
-use strict;
-
package Encode::Plain;
-require 5.6.0;
+################################################################################
+# #
+# File: shared/Encode/Plain.pm #
+# #
+# Authors: André Malo <nd@o3media.de>, 2001-04-12 #
+# #
+# Description: Encode text for HTML Output (entities, spaces) #
+# #
+################################################################################
-use vars qw(@EXPORT %sonder %unimap $utf8);
+use strict;
+use vars qw(
+ @EXPORT
+ %sonder
+ %unimap
+ $utf8
+ $v56
+);
-# ====================================================
-# Funktionsexport
-# ====================================================
+$v56 = eval {local $SIG{__DIE__}; require 5.6.0;};
+################################################################################
+#
+# Export
+#
use base qw(Exporter);
@EXPORT = qw(plain multiline toUTF8);
-################################
-# sub plain
+### sub myunpack ###############################################################
+#
+# if perl version < 5.6 use myunpack instead of unpack 'U' ;(
+#
+# Params: $string - UTF8-encoded string to unpack
+#
+# Return: Number - unpacked UTF8
#
-# einfache Sonderzeichen ->
-# Entity-Codierung
-################################
+sub myunpack ($) {
+ return unless defined $_[0];
+
+ my @c = map {ord} split // => shift;
+
+ return ($c[0] & 31) << 6 | $c[1] & 63
+ if (
+ @c == 2
+ and ($c[0] & 224) == 192
+ and ($c[1] & 192) == 128
+ );
+
+ return ($c[0] & 15) << 12 | ($c[1] & 63) << 6 | $c[2] && 63
+ if (
+ @c == 3
+ and ($c[0] & 240) == 224
+ and ($c[1] & 192) == 128
+ and ($c[2] & 192) == 128
+ );
+
+ return;
+}
+### sub plain ##################################################################
+#
+# encode characters of plain text into entities for HTML output
+# (includes < > " &)
+# (excludes space problem)
+#
+# Params: $old - String (or scalar reference) to encode
+# $ref - (optional) (hash reference) Options
+# (-amp -except -utf8)
+#
+# Return: encoded string (or scalar reference)
+#
sub plain ($;$) {
- my ($old,$ref)=@_;
+ my ($old, $ref) = @_;
my $exreg;
- return \'' unless (defined $old);
+ return unless (defined $old);
- my $new=(ref ($old))?$$old:$old;;
- $ref=($ref or {});
+ my $new = ref ($old) ? $$old : $old;
+ $ref = $ref || {};
+ $new ='' unless (defined $new);
- # Ausnahmen
- my $except=exists($ref->{-except});
+ my $unicode = defined ($ref -> {-utf8})
+ ? $ref -> {-utf8}
+ : $utf8;
+
+ # Exceptions
+ #
+ my $except = exists($ref->{-except});
if ($except) {
- # Referenz, also Liste uebergeben -> umwandeln in Regex
if (ref ($ref -> {-except})) {
- $exreg = join ('|',map {quotemeta $_} @{$ref -> {-except}});}
-
- # keine Referenz, also Regex angegeben
+ # turn list into a regex
+ #
+ $exreg = join '|' => map {quotemeta $_} @{$ref -> {-except}};
+ }
else {
+ # quote regex delimiters
+ #
$exreg = $ref -> {-except};
- $exreg =~ s/\//\\\//g;}} # LTS :-)
+ $exreg =~ s|/|\\/|g;
+ }
+ }
+ # encode the &-character
+ #
if (lc($ref->{-amp}) eq 'soft') {
if ($except) {
- $new=~s/($exreg)|(?:\&(?!(?:#[Xx][\da-fA-F]+|#\d+|[a-zA-Z]+);))/(length($1))?$1:'&'/eg;}
-
+ $new=~s/($exreg)|(?:\&(?!(?:#[Xx][\da-fA-F]+|#\d+|[a-zA-Z]+);))/defined($1)?$1:'&'/eg;
+ }
else {
- $new=~s/\&(?!(?:#[Xx][\da-fA-F]+|#\d+|[a-zA-Z]+);)/&/g;}}
-
+ $new=~s/\&(?!(?:#[Xx][\da-fA-F]+|#\d+|[a-zA-Z]+);)/&/g;
+ }
+ }
elsif (lc($ref->{-amp}) ne 'no') {
if ($except) {
- $new=~s/($exreg)|\&/(length($1))?$1:'&'/eg;}
-
+ $new=~s/($exreg)|\&/defined($1)?$1:'&'/eg;
+ }
else {
- $new=~s/\&/&/g;}}
+ $new=~s/\&/&/g;
+ }
+ }
- # Weitere Zeichen
+ # further characters
+ #
if ($except) {
- $new =~ s/($exreg)|</(length($1))?$1:'<'/eg; # HTML ausschalten
- $new =~ s/($exreg)|>/(length($1))?$1:'>'/eg;
- $new =~ s/($exreg)|\|/(length($1))?$1:'|'/eg; # nich wahr
- $new =~ s/($exreg)|"/(length($1))?$1:'"'/eg; # Diese Zeile wird den Bannerklickern
- # zu schaffen machen, sowas aber auch...
-
- # Der grosse Hash
- if ($utf8 or $ref -> {-utf8}) {
+ $new =~ s/($exreg)|</defined($1)?$1:'<'/eg;
+ $new =~ s/($exreg)|>/defined($1)?$1:'>'/eg;
+ $new =~ s/($exreg)|\|/defined($1)?$1:'|'/eg;
+ $new =~ s/($exreg)|"/defined($1)?$1:'"'/eg;
+
+ # the big hash
+ #
+ if ($unicode) {
my $x;
- $new =~ s/($exreg)|([\300-\337][\200-\277]|[\340-\357][\200-\277][\200-\277])/
- length($1)?$1:(exists($unimap{$x = unpack('U',$2)})?$unimap{$x}:"&#$x;")/eg;}
-
- $new =~ s/($exreg)|([\177-\377])/(length($1))?$1:$sonder{$2}/eg;}
-
+ if ($v56) {
+ $new =~ s/($exreg)|([\300-\337][\200-\277]|[\340-\357][\200-\277][\200-\277])/
+ defined($1)
+ ? $1
+ : ( exists($unimap{$x = unpack('U',$2)})
+ ? $unimap{$x}
+ : "&#$x;"
+ )
+ /eg;
+ }
+ else {
+ $new =~ s/($exreg)|([\300-\337][\200-\277]|[\340-\357][\200-\277][\200-\277])/
+ defined($1)
+ ? $1
+ : ( exists($unimap{$x = myunpack($2)})
+ ? $unimap{$x}
+ : "&#$x;"
+ )
+ /eg;
+ }
+ }
+ $new =~ s/($exreg)|([\177-\377])/defined($1)?$1:$sonder{$2}/eg;
+ }
else {
+ # no exceptions
+ #
$new =~ s/</</g;
$new =~ s/>/>/g;
$new =~ s/\|/|/g;
$new =~ s/"/"/g;
- # Der grosse Hash
- if ($utf8 or $ref -> {-utf8}) {
+ # the big hash
+ #
+ if ($unicode) {
my $x;
- $new =~ s/([\300-\337][\200-\277]|[\340-\357][\200-\277][\200-\277])/
- exists($unimap{$x = unpack('U',$1)})?$unimap{$x}:"&#$x;"/eg;}
-
- $new =~ s/([\177-\377])/$sonder{$1}/g;}
-
- # Zeichen <= 31
- $new=~s/([\001-\010\013\014\016-\037])/'&#'.ord($1).';'/eg;
+ if ($v56) {
+ $new =~ s/([\300-\337][\200-\277]|[\340-\357][\200-\277][\200-\277])/
+ exists($unimap{$x = unpack('U',$1)})
+ ? $unimap{$x}
+ : "&#$x;"
+ /eg;
+ }
+ else {
+ $new =~ s/([\300-\337][\200-\277]|[\340-\357][\200-\277][\200-\277])/
+ exists($unimap{$x = myunpack($1)})
+ ? $unimap{$x}
+ : "&#$x;"
+ /eg;
+ }
+ }
+ $new =~ s/([\177-\377])/$sonder{$1}/g;
+ }
+
+ # characters < 32, but whitespaces
+ #
+ $new=~s/([^\041-\377\000\s])/
+ '&#' . ord($1) . ';'
+ /eg;
$new=~s/\000/ /g;
- # Rueckgabe
- ref($old)?\$new:$new;
+ # return
+ #
+ ref $old
+ ? \$new
+ : $new;
}
-################################
-# sub multiline
+### sub multiline ##############################################################
+#
+# solve the space problem
#
-# Whitespacecodierung
-# fuer Leerzeilen
-################################
+# Params: $old - String (or scalar reference): text to encode
+#
+# Return: scalar reference: encoded string
+#
+sub multiline ($) {
+ my $old = shift;
+ my $string=(ref ($old))
+ ? $$old
+ : $old;
-sub multiline {
- my $old=shift;
- my $string=(ref ($old))?$$old:$old;
+ $string='' unless (defined $string);
- # Zeilenumbrueche normalisieren
+ # normalize newlines
+ #
$string=~s/\015\012|\015|\012/\n/g;
- # Zeilenumbrueche in <br> umwandeln
+ # turn \n into <br>
+ #
$string=~s/\n/<br>/g;
- # mehr als ein aufeinanderfolgendes
- # Leerzeichen in feste Leerzeichen umwandeln
+ # more than 1 space =>
+ #
$string=~s/(\s\s+)/(' ' x (length($1)-1)) . ' '/eg;
- # Leerzeichen nach einem <br> in feste
- # Spaces umwandeln
- $string=~s/(?:^|(<br>))\s/$1 /g;
+ # Single Spaces after <br> =>
+ # (save ascii arts ;)
+ #
+ $string=~s/(?:^|(<br>))\s/($1?$1:'').' '/eg;
- # Rueckgabe
+ # return
+ #
\$string;
}
+### sub toUTF8 #################################################################
+#
+# map ISO-8859-1 to UTF8
+#
+# Params: String or scalar reference: string to map
+#
+# Return: String or scalar reference: mapped string
+#
sub toUTF8 ($) {
my $ref = shift;
- my $string = ref($ref)?$$ref:$ref;
- no warnings 'utf8';
-
- $string =~ tr/\x80-\xff//CU;
-
- ref($ref)?\$string:$string;
+ my $string = ref($ref)
+ ? $$ref
+ : $ref;
+
+ if ($v56) {
+ no warnings 'utf8';
+ $string =~ tr/\x80-\xff//CU;
+ }
+ else {
+ $string =~ s
+ {([\x80-\xff])}
+ { chr((ord ($1) >> 6) | 192)
+ .chr((ord ($1) & 191))
+ }eg;
+ }
+
+ ref($ref)
+ ? \$string
+ : $string;
}
-# ====================================================
-# Modulinitialisierung
-# ====================================================
-
+################################################################################
+#
+# package init
+#
BEGIN {
$utf8 = 0;
- # Latin 1 + geraten
- %sonder=("\177" => '', # Delete-Zeichen
- "\200" => '€', # Euro-Zeichen
- "\201" => 'ü', # ue - DOS-Zeichensatz
- "\202" => '‚', # einfaches Anfuehrungszeichen unten
- "\203" => 'ƒ', # forte
- "\204" => '„', # doppelte Anfuehrungszeichen unten
- "\205" => '…', # drei punkte
- "\206" => '†', # dagger
- "\207" => '‡', # Dagger
- "\210" => 'ˆ', # circ
- "\211" => '‰', # Promille
- "\212" => 'Š', # so ein S mit Haken drueber :-)
- "\213" => '‹', # lsaquo
- "\214" => 'Œ', # OE (so verhakelt - daenisch?) wer weiss das schon
- "\215" => 'ì', # Codepage 850;
- "\216" => 'Ž', # Z mit Haken drueber (Latin Extended B)
- "\217" => 'Å', # Codepage 850 (Win)
- "\220" => 'ü', # ue - Mac-Zeichensatz
- "\221" => "'", # einfache Anfuehrungszeichen oben
- "\222" => "'", # dito
- "\223" => '“', # doppelte Anfuehrungszeichen oben
- "\224" => '“', # dito
- "\225" => '•', # Bullet
- "\226" => '-', # Bindestrich
- "\227" => '-', # dito
- "\230" => '˜', # tilde...?
- "\231" => '™', # Trade-Mark
- "\232" => 'š', # kleines s mit Haken drueber
- "\233" => '›', # rsaquo;
- "\234" => 'œ', # oe verhakelt
- "\235" => 'Ø', # Codepage 850 (Win)
- "\236" => '×', # Codepage 850 (Win)
- "\237" => 'Ÿ', # Y mit Punkten drueber
- "\240" => ' ', # nbsp;
- "\241" => '¡', # umgedrehtes !
- "\242" => '¢', # cent-Zeichen
- "\243" => '£', # (engl.)Pfund-Zeichen
- "\244" => '¤', # Waehrungszeichen
- "\245" => '¥', # Yen halt :-)
- "\246" => '¦', # eigentlich soll es wohl ein | sein .-)
- "\247" => '§', # Paragraph
- "\250" => '¨', # zwei Punkte oben
- "\251" => '©', # (C)
- "\252" => 'ª', # hochgestelltes unterstrichenes a
- "\253" => '«', # left-pointing double angle quotation mark (besser koennte ichs auch nicht beschreiben...)
- "\254" => '¬', # Negationszeichen
- "\255" => '-', # Bindestrich
- "\256" => '®', # (R)
- "\257" => 'ß', # sz, was auch immer fuern Zeichensatz (DOS?)
- "\260" => '°', # Grad-Zeichen
- "\261" => '±', # Plusminus
- "\262" => '²', # hoch 2
- "\263" => '³', # hoch 3
- "\264" => '´', # Acute
- "\265" => 'µ', # my-Zeichen (griech)
- "\266" => '¶', # Absatzzeichen
- "\267" => '·', # Mal-Zeichen
- "\270" => '¸',
- "\271" => '¹', # hoch 1
- "\272" => 'º', # masculine ordinal indicator (spanish)
- "\273" => '»', # right-pointing double angle quotation mark
- "\274" => '¼', # 1/4
- "\275" => '½', # 1/2
- "\276" => '¾', # 3/4
- "\277" => '¿', # umgedrehtes ?
- "\300" => 'À',
- "\301" => 'Á',
- "\302" => 'Â',
- "\303" => 'Ã',
- "\304" => 'Ä',
- "\305" => 'Å',
- "\306" => 'Æ',
- "\307" => 'Ç',
- "\310" => 'È',
- "\311" => 'É',
- "\312" => 'Ê',
- "\313" => 'Ë',
- "\314" => 'Ì',
- "\315" => 'Í',
- "\316" => 'Î',
- "\317" => 'Ï',
- "\320" => 'Ð', # keine Ahnung, was das wohl sein soll, auf jeden Fall was islaendisches...
- "\321" => 'Ñ',
- "\322" => 'Ò',
- "\323" => 'Ó',
- "\324" => 'Ô',
- "\325" => 'Õ',
- "\326" => 'Ö',
- "\327" => '×', # eigentlich × funzt afaik aber nicht aufm Mac (ob das hier funktioniert, weiss ich nicht)
- "\330" => 'Ø',
- "\331" => 'Ù',
- "\332" => 'Ú',
- "\333" => 'Û',
- "\334" => 'Ü',
- "\335" => 'Ý',
- "\336" => 'Þ',
- "\337" => 'ß',
- "\340" => 'à',
- "\341" => 'á',
- "\342" => 'â',
- "\343" => 'ã',
- "\344" => 'ä',
- "\345" => 'å',
- "\346" => 'æ',
- "\347" => 'ç',
- "\350" => 'è',
- "\351" => 'é',
- "\352" => 'ê',
- "\353" => 'ë',
- "\354" => 'ì',
- "\355" => 'í',
- "\356" => 'î',
- "\357" => 'ï',
- "\360" => 'ð',
- "\361" => 'ñ',
- "\362" => 'ò',
- "\363" => 'ó',
- "\364" => 'ô',
- "\365" => 'õ',
- "\366" => 'ö',
- "\367" => '÷',
- "\370" => 'ø',
- "\371" => 'ù',
- "\372" => 'ú',
- "\373" => 'û',
- "\374" => 'ü',
- "\375" => 'ý',
- "\376" => 'þ',
- "\377" => 'ÿ');
+ # Latin 1 + guessed
+ #
+ %sonder=(
+ "\177" => '',
+ "\200" => '€',
+ "\201" => 'ü',
+ "\202" => '‚',
+ "\203" => 'ƒ',
+ "\204" => '„',
+ "\205" => '…',
+ "\206" => '†',
+ "\207" => '‡',
+ "\210" => 'ˆ',
+ "\211" => '‰',
+ "\212" => 'Š',
+ "\213" => '‹',
+ "\214" => 'Œ',
+ "\215" => 'ì',
+ "\216" => 'Ž',
+ "\217" => 'Å',
+ "\220" => 'ü',
+ "\221" => "'",
+ "\222" => "'",
+ "\223" => '“',
+ "\224" => '“',
+ "\225" => '•',
+ "\226" => '-',
+ "\227" => '-',
+ "\230" => '˜',
+ "\231" => '™',
+ "\232" => 'š',
+ "\233" => '›',
+ "\234" => 'œ',
+ "\235" => 'Ø',
+ "\236" => '×',
+ "\237" => 'Ÿ',
+ "\240" => ' ',
+ "\241" => '¡',
+ "\242" => '¢',
+ "\243" => '£',
+ "\244" => '¤',
+ "\245" => '¥',
+ "\246" => '¦',
+ "\247" => '§',
+ "\250" => '¨',
+ "\251" => '©',
+ "\252" => 'ª',
+ "\253" => '«',
+ "\254" => '¬',
+ "\255" => '-',
+ "\256" => '®',
+ "\257" => 'ß',
+ "\260" => '°',
+ "\261" => '±',
+ "\262" => '²',
+ "\263" => '³',
+ "\264" => '´',
+ "\265" => 'µ',
+ "\266" => '¶',
+ "\267" => '·',
+ "\270" => '¸',
+ "\271" => '¹',
+ "\272" => 'º',
+ "\273" => '»',
+ "\274" => '¼',
+ "\275" => '½',
+ "\276" => '¾',
+ "\277" => '¿',
+ "\300" => 'À',
+ "\301" => 'Á',
+ "\302" => 'Â',
+ "\303" => 'Ã',
+ "\304" => 'Ä',
+ "\305" => 'Å',
+ "\306" => 'Æ',
+ "\307" => 'Ç',
+ "\310" => 'È',
+ "\311" => 'É',
+ "\312" => 'Ê',
+ "\313" => 'Ë',
+ "\314" => 'Ì',
+ "\315" => 'Í',
+ "\316" => 'Î',
+ "\317" => 'Ï',
+ "\320" => 'Ð',
+ "\321" => 'Ñ',
+ "\322" => 'Ò',
+ "\323" => 'Ó',
+ "\324" => 'Ô',
+ "\325" => 'Õ',
+ "\326" => 'Ö',
+ "\327" => '×',
+ "\330" => 'Ø',
+ "\331" => 'Ù',
+ "\332" => 'Ú',
+ "\333" => 'Û',
+ "\334" => 'Ü',
+ "\335" => 'Ý',
+ "\336" => 'Þ',
+ "\337" => 'ß',
+ "\340" => 'à',
+ "\341" => 'á',
+ "\342" => 'â',
+ "\343" => 'ã',
+ "\344" => 'ä',
+ "\345" => 'å',
+ "\346" => 'æ',
+ "\347" => 'ç',
+ "\350" => 'è',
+ "\351" => 'é',
+ "\352" => 'ê',
+ "\353" => 'ë',
+ "\354" => 'ì',
+ "\355" => 'í',
+ "\356" => 'î',
+ "\357" => 'ï',
+ "\360" => 'ð',
+ "\361" => 'ñ',
+ "\362" => 'ò',
+ "\363" => 'ó',
+ "\364" => 'ô',
+ "\365" => 'õ',
+ "\366" => 'ö',
+ "\367" => '÷',
+ "\370" => 'ø',
+ "\371" => 'ù',
+ "\372" => 'ú',
+ "\373" => 'û',
+ "\374" => 'ü',
+ "\375" => 'ý',
+ "\376" => 'þ',
+ "\377" => 'ÿ'
+ );
# Unicode-Mapping
- %unimap=(128 => '€',
- 129 => 'ü',
- 130 => '‚',
- 131 => 'ƒ',
- 132 => '„',
- 133 => '…',
- 134 => '†',
- 135 => '‡',
- 136 => 'ˆ',
- 137 => '‰',
- 138 => 'Š',
- 139 => '‹',
- 140 => 'Œ',
- 141 => 'ì',
- 142 => 'Ž',
- 143 => 'Å',
- 144 => 'ü',
- 145 => "'",
- 146 => "'",
- 147 => '“',
- 148 => '“',
- 149 => '•',
- 150 => '-',
- 151 => '-',
- 152 => '˜',
- 153 => '™',
- 154 => 'š',
- 155 => '›',
- 156 => 'œ',
- 157 => 'Ø',
- 158 => '×',
- 159 => 'Ÿ',
- 160 => ' ',
- 163 => '£',
- 165 => '¥',
- 167 => '§',
- 169 => '©',
- 171 => '«',
- 173 => '-',
- 174 => '®',
- 175 => 'ß',
- 180 => '´',
- 184 => '¸',
- 185 => '¹',
- 187 => '»',
- 192 => 'À',
- 193 => 'Á',
- 194 => 'Â',
- 195 => 'Ã',
- 196 => 'Ä',
- 197 => 'Å',
- 198 => 'Æ',
- 199 => 'Ç',
- 200 => 'È',
- 201 => 'É',
- 202 => 'Ê',
- 203 => 'Ë',
- 204 => 'Ì',
- 205 => 'Í',
- 206 => 'Î',
- 207 => 'Ï',
- 208 => 'Ð',
- 209 => 'Ñ',
- 210 => 'Ò',
- 211 => 'Ó',
- 212 => 'Ô',
- 213 => 'Õ',
- 214 => 'Ö',
- 216 => 'Ø',
- 217 => 'Ù',
- 218 => 'Ú',
- 219 => 'Û',
- 220 => 'Ü',
- 221 => 'Ý',
- 222 => 'Þ',
- 223 => 'ß',
- 224 => 'à',
- 225 => 'á',
- 226 => 'â',
- 227 => 'ã',
- 228 => 'ä',
- 229 => 'å',
- 230 => 'æ',
- 231 => 'ç',
- 232 => 'è',
- 233 => 'é',
- 234 => 'ê',
- 235 => 'ë',
- 236 => 'ì',
- 237 => 'í',
- 238 => 'î',
- 239 => 'ï',
- 240 => 'ð',
- 241 => 'ñ',
- 242 => 'ò',
- 243 => 'ó',
- 244 => 'ô',
- 245 => 'õ',
- 246 => 'ö',
- 247 => '÷',
- 248 => 'ø',
- 249 => 'ù',
- 250 => 'ú',
- 251 => 'û',
- 252 => 'ü',
- 253 => 'ý',
- 254 => 'þ',
- 255 => 'ÿ');
+ %unimap=(
+ 128 => '€',
+ 129 => 'ü',
+ 130 => '‚',
+ 131 => 'ƒ',
+ 132 => '„',
+ 133 => '…',
+ 134 => '†',
+ 135 => '‡',
+ 136 => 'ˆ',
+ 137 => '‰',
+ 138 => 'Š',
+ 139 => '‹',
+ 140 => 'Œ',
+ 141 => 'ì',
+ 142 => 'Ž',
+ 143 => 'Å',
+ 144 => 'ü',
+ 145 => "'",
+ 146 => "'",
+ 147 => '“',
+ 148 => '“',
+ 149 => '•',
+ 150 => '-',
+ 151 => '-',
+ 152 => '˜',
+ 153 => '™',
+ 154 => 'š',
+ 155 => '›',
+ 156 => 'œ',
+ 157 => 'Ø',
+ 158 => '×',
+ 159 => 'Ÿ',
+ 160 => ' ',
+ 163 => '£',
+ 165 => '¥',
+ 167 => '§',
+ 169 => '©',
+ 171 => '«',
+ 173 => '-',
+ 174 => '®',
+ 175 => 'ß',
+ 180 => '´',
+ 184 => '¸',
+ 185 => '¹',
+ 187 => '»',
+ 192 => 'À',
+ 193 => 'Á',
+ 194 => 'Â',
+ 195 => 'Ã',
+ 196 => 'Ä',
+ 197 => 'Å',
+ 198 => 'Æ',
+ 199 => 'Ç',
+ 200 => 'È',
+ 201 => 'É',
+ 202 => 'Ê',
+ 203 => 'Ë',
+ 204 => 'Ì',
+ 205 => 'Í',
+ 206 => 'Î',
+ 207 => 'Ï',
+ 208 => 'Ð',
+ 209 => 'Ñ',
+ 210 => 'Ò',
+ 211 => 'Ó',
+ 212 => 'Ô',
+ 213 => 'Õ',
+ 214 => 'Ö',
+ 216 => 'Ø',
+ 217 => 'Ù',
+ 218 => 'Ú',
+ 219 => 'Û',
+ 220 => 'Ü',
+ 221 => 'Ý',
+ 222 => 'Þ',
+ 223 => 'ß',
+ 224 => 'à',
+ 225 => 'á',
+ 226 => 'â',
+ 227 => 'ã',
+ 228 => 'ä',
+ 229 => 'å',
+ 230 => 'æ',
+ 231 => 'ç',
+ 232 => 'è',
+ 233 => 'é',
+ 234 => 'ê',
+ 235 => 'ë',
+ 236 => 'ì',
+ 237 => 'í',
+ 238 => 'î',
+ 239 => 'ï',
+ 240 => 'ð',
+ 241 => 'ñ',
+ 242 => 'ò',
+ 243 => 'ó',
+ 244 => 'ô',
+ 245 => 'õ',
+ 246 => 'ö',
+ 247 => '÷',
+ 248 => 'ø',
+ 249 => 'ù',
+ 250 => 'ú',
+ 251 => 'û',
+ 252 => 'ü',
+ 253 => 'ý',
+ 254 => 'þ',
+ 255 => 'ÿ'
+ );
}
-# making require happy
+# keeping require happy
1;
-# ====================================================
-# end of Encode::Plain
-# ====================================================
\ No newline at end of file
+#
+#
+### end of Encode::Plain #######################################################
\ No newline at end of file
-# Posting.pm
+package Encode::Posting;
-# ====================================================
-# Autor: n.d.p. / 2001-01-07
-# lm : n.d.p. / 2001-02-25
-# ====================================================
-# Funktion:
-# Spezielle Codierung eines Postingtextes
-# ====================================================
+################################################################################
+# #
+# File: shared/Encode/Posting.pm #
+# #
+# Authors: André Malo <nd@o3media.de>, 2001-04-10 #
+# #
+# Description: prepare a Posting text for saving and visual (HTML) output #
+# #
+################################################################################
use strict;
-package Encode::Posting;
-
-use vars qw(@EXPORT);
use Encode::Plain; $Encode::Plain::utf8 = 1;
+use CheckRFC;
-# ====================================================
-# Funktionsexport
-# ====================================================
-
+################################################################################
+#
+# Export
+#
use base qw(Exporter);
-@EXPORT = qw(encoded_body answer_field message_field);
+@Encode::Posting::EXPORT = qw(
+ encoded_body
+ answer_field
+ message_field
+);
-################################
-# sub encoded_body
+### sub rel_uri ($$) ###########################################################
+#
+# generate an absolute URI from a absolute|relative one
+# (not for public use)
#
-# Nachrichtentext in gueltiges
-# HTML konvertieren
-################################
+# Params: $uri - URI
+# $base - base URI
+#
+# Return: abs URI as string
+#
+sub rel_uri ($$) {
+ my ($uri, $base) = @_;
+
+ "http://$ENV{HTTP_HOST}".
+ ($uri =~ m|^/|
+ ? $uri
+ : "$base$uri");
+}
+### sub encoded_body ($;$) #####################################################
+#
+# prepare posting text for saving
+#
+# Params: $posting - scalar reference of the raw text
+# $params - hash reference
+# (quoteChars messages)
+#
+# Return: scalar reference of the encoded text
+#
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
+ $posting =~ s/\015\012|\015|\012/\n/g; # normalize newlines
+ $posting =~ s/[^\S\n]$//gm; # kill whitespaces at the end of all lines
+ $posting =~ s/\s+$//; # kill whitespaces (newlines) at the end of the string (text)
+
+ # check the special syntaxes:
+
+ my $base = $params -> {base_uri};
+ # collect all [link:...] strings
+ #
+ my @rawlinks;
+ push @rawlinks => [$1 => $2] while ($posting =~ /\[([Ll][Ii][Nn][Kk]):\s*([^\]\s]+)\s*\]/g);
+ my @links = grep {
+ is_URL ( $_ -> [1] => ':ALL')
+ or is_URL (($_ -> [1] =~ /^[Vv][Ii][Ee][Ww]-[Ss][Oo][Uu][Rr][Cc][Ee]:(.+)/)[0] || '' => 'http')
+ or ( $_ -> [1] =~ m<^\.?\.?/(?!/)|\?>
+ and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
+ } @rawlinks;
+
+ # collect all [image:...] strings
+ #
+ my @rawimages;
+ push @rawimages => [$1 => $2] while ($posting =~ /\[([Ii][Mm][Aa][Gg][Ee]):\s*([^\]\s]+)\s*\]/g);
+ my @images = grep {
+ is_URL ($_ -> [1] => 'strict_http')
+ or ( $_ -> [1] =~ m<^\.?\.?/(?!/)|\?>
+ and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
+ } @rawimages;
+
+ # collect all [iframe:...] strings
+ #
+ my @rawiframes;
+ push @rawiframes => [$1 => $2] while ($posting =~ /\[([Ii][Ff][Rr][Aa][Mm][Ee]):\s*([^\]\s]+)\s*\]/g);
+ my @iframes = grep {
+ is_URL ($_ -> [1] => 'http')
+ or is_URL (($_ -> [1] =~ /^[Vv][Ii][Ee][Ww]-[Ss][Oo][Uu][Rr][Cc][Ee]:(.+)/)[0] || '' => 'http')
+ or ( $_ -> [1] =~ m<^\.?\.?/(?!/)|\?>
+ and is_URL (rel_uri ($_ -> [1], $base) => 'http'))
+ } @rawiframes;
+
+ # collect all [msg:...] strings
+ #
+ $params -> {messages} = {} unless (defined $params -> {messages});
+ my %msg = map {lc($_) => $params -> {messages} -> {$_}} keys %{$params -> {messages}};
- # 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));
+ my @rawmsgs;
+ push @rawmsgs => [$1 => $2] while ($posting =~ /\[([Mm][Ss][Gg]):\s*([^\]\s]+)\s*\]/g);
+ my @msgs = grep {exists ($msg{lc($_ -> [1])})} @rawmsgs;
- # Multine
- $posting = ${multiline (\$posting)};
+ # encode Entities and special characters
+ #
+ $posting = ${plain (\$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|&(?!amp;)|\(|\)|<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|\]|(\(|\)|&(?!amp;)|<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|\(|\)|&(?!amp;)|<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|\(|\)|&(?!amp;)|<br>)) # der Begrenzer (\s, ] oder Zeilenende)
- }
- {<iframe src="$1" width="90%" height="90%"><a href="$1">$1</a></iframe>$2}gix;
+ # encode the special syntaxes
+ #
+ $posting =~ s!$_!<a href="$1">$1</a>!
+ for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @links);
- # [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;}
+ $posting =~ s!$_!<img src="$1" border=0 alt="">!
+ for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @images);
+
+ $posting =~ s!$_!<iframe src="$1" width="90%" height="90%"><a href="$1">$1</a></iframe>!
+ for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @iframes);
+
+ %msg = map {plain($_) => $msg{$_}} keys %msg;
+ $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
+ for (map {qr/\[\Q${plain(\$_->[0])}\E:\s*(\Q${plain(\$_->[1])}\E)\s*\]/} @msgs);
+
+ # normalize quote characters (quote => \177)
+ #
+ my $quote = plain(defined $params -> {quoteChars} ? $params -> {quoteChars} : '');
+ my $len = length ($quote);
+ $posting =~ s!^((?:\Q$quote\E)+)!"\177" x (length($1)/$len)!gem if ($len);
+
+ # \n => <br>, fix spaces
+ #
+ $posting = ${multiline (\$posting)};
- # Rueckgabe
+ # return
+ #
\$posting;
}
-################################
-# sub answer_field
+### sub answer_field ($$) ######################################################
+#
+# create the content of the answer textarea
+#
+# Params: $posting - scalar reference
+# (posting text, 'encoded_body' encoded)
+# $params - hash reference
+# (quoteArea quoteChars messages)
+#
+# Return: scalar reference
#
-# Antwort HTML einer Message
-# erzeugen
-################################
-
sub answer_field ($$) {
my $posting = shift;
- my $params = shift;
- $params = {} unless (defined $params);
+ my $params = shift || {};
- # ================
- # Antwortfeld
- # ================
my $area = $$posting;
-
my $qchar = $params -> {quoteChars};
- $area =~ s/(?:^|(<br>))(?!<br>)/$1 || '' . "\177"/eg if ($params -> {quoteArea}); # Antwortfeld quoten?!
- $area =~ s/\177/$qchar/g; # normalisierte Quotes jedenfalls in Chars umsetzen
+ $area =~ s/<br>/\n/g; # <br> => \n
+ $area =~ s/&(?:#160|nbsp);/ /g; # nbsp => ' '
- # HTML-Zeug zurueckuebersetzen
+ $area =~ s/^(.)/\177$1/gm if ($params -> {quoteArea}); # shift a quoting character
+ $area =~ s/^(\177+)/$qchar x length ($1)/gem; # decode normalized quoting characters
- $params -> {messages} = {} unless (defined $params -> {messages}); # um Fehlermeldungen auszuschliessen...
- my %msg = map {($params -> {messages} -> {$_} -> {src} => $_)} keys %{$params -> {messages}};
+ # recode special syntaxes
+ # from HTML to [...] constructions
+ #
+ $params -> {messages} = {} unless (defined $params -> {messages}); # avoid error messages
+ my %msg = map {
+ $params -> {messages} -> {$_} -> {src} => $_
+ } keys %{$params -> {messages}}; # we have to lookup reverse ...
- $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;
+ # [msg...]
+ $area =~ s{(<img\s+src="([^"]+)"\s+width[^>]+>)} {
+ defined $msg{$2}
+ ? "[msg: $msg{$2}]"
+ : $1;
+ }ge;
- # Rueckgabe
+ # [iframe...]
+ $area =~ s{<iframe\s+src="([^"]*)"[^>]+>.*?</iframe>} {[iframe: $1]}g;
+
+ # [image...]
+ $area =~ s{<img src="([^"]*)"[^>]*>}{[image: $1]}g;
+
+ # [link...]
+ $area =~ s{<a href="([^"]*)">.*?</a>}{[link: $1]}g;
+
+ # return
+ #
\$area;
}
-################################
-# sub message_field
+### sub message_field ($$) #####################################################
+#
+# prepare the posting text for visual output
+#
+# Params: $posting - scalar reference
+# (raw posting text, 'encoded_body' encoded)
+# $params - hash reference
+# (quoteChars quoting startCite endCite)
+#
+# Return: scalar rerence (prepared posting text)
#
-# HTML eines Postingtextes
-# erzeugen
-################################
-
sub message_field ($$) {
my $posting = ${+shift};
- my $params = shift;
- $params = {} unless (defined $params);
+ my $params = shift || {};
+
+
+ if ($params -> {quoting}) { # quotes are displayed as special?
+ my @array = [0 => []];
+
+ for (split /<br>/ => $posting) {
+ my $l = length ((/^(\177*)/)[0]);
+ if ($array[-1][0] == $l) {
+ push @{$array[-1][-1]} => $_;
+ }
+ else {
+ push @array => [$l => [$_]];
+ }
+ }
+ shift @array unless @{$array[0][-1]};
+
+ $posting = join '<br>' => map {
+ $_->[0]
+ ? join join ('<br>' => @{$_->[-1]}) => ($params->{startCite}, $params->{endCite})
+ : (join '<br>' => @{$_->[-1]});
+ } @array;
+ }
- # ================
- # Postingtext
- # ================
my $qchar = $params -> {quoteChars};
+ $posting =~ s/\177/$qchar/g; # \177 => quote chars
- 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 or ''); # 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
+ # return
+ #
\$posting;
}
-
-# ====================================================
-# Modulinitialisierung
-# ====================================================
-
-# making require happy
+# keeping 'require' happy
1;
-# ====================================================
-# end of Encode::Posting
-# ====================================================
\ No newline at end of file
+#
+#
+### end of Encode::Posting #####################################################
\ No newline at end of file
body => encoded_body(
\($param -> {body}),
{ quoteChars => $param -> {quoteChars},
- messages => $param -> {messages}
+ messages => $param -> {messages},
+ base_uri => $param -> {base_uri}
}
),
time => $param -> {time},
${encoded_body(
\($param -> {body}),
{ quoteChars => $param -> {quoteChars},
- messages => $param -> {messages}
+ messages => $param -> {messages},
+ base_uri => $param -> {base_uri}
}
)}
)
return (0, $thread, $mid);
}
-# keeping 'require' happy
+# keep 'require' happy
#
1;
-# Template.pm
+package Template;
-# ====================================================
-# Autor: n.d.p. / 2001-01-06
-# lm : n.d.p. / 2001-01-25
-# ====================================================
-# Funktion:
-# Ausfuellen von Templates
-# ====================================================
+################################################################################
+# #
+# File: shared/Template.pm #
+# #
+# Authors: André Malo <nd@o3media.de>, 2001-04-12 #
+# #
+# Description: Handle XML based HTML-Templates #
+# #
+################################################################################
use strict;
+use vars qw($xml_dom_used);
-package Template;
-
-use autouse 'Carp' => qw(croak confess);
-use XML::DOM;
+use Carp qw(croak confess);
-# ====================================================
-# Methoden
-# ====================================================
+BEGIN {
+ $xml_dom_used = eval q[
+ local $SIG{__DIE__};
+ use XML::DOM;
+ 1;
+ ];
+}
-################################
-# sub new
+### sub new ####################################################################
+#
+# constructor
+#
+# Params: ~none~
+#
+# Return: Template object
#
-# Konstruktor
-################################
-
sub new {
- my $instance=shift;
- my $class=(ref($instance) or $instance);
+ my $instance = shift;
- my $self = {};
- $self = bless $self,$class;
+ my $self = bless {} => ref($instance) || $instance;
$self -> file (+shift);
- # Rueckgabe
+ # return
$self;
}
-################################
-# sub file
+### sub file ###################################################################
+#
+# assign new template file to object
+# parse the template file
+#
+# Params: $new - (optional) new template file
+#
+# Return: scalar - old filename or if there's no old filename given
#
-# Datei zuweisen und parsen
-################################
-
sub file {
my $self = shift;
- my $old = $self -> {file};
- my $new = shift;
+ my $new = shift;
+ my $old = $self -> {file};
$self -> {file} = $new if (defined $new);
$self -> parse_file;
+ # return
$old;
}
-################################
-# sub insert
+### sub insert #################################################################
+#
+# return the placeholder surrounded by meta delimiters
+#
+# Params: $name - name of placeholder
+#
+# Return: scalar - placeholder surrounded by meta delimiters
#
-# Bezeichner in Metazeichen
-# eingeschlossen zurueckgeben
-################################
-
sub insert {
- my $self=shift;
- croak "no template file specified" unless (defined $self -> {file});
+ my $self = shift;
+ my $name = shift;
- my $name=shift;
+ croak "no template file specified"
+ unless (defined $self -> {file});
- # Rueckgabe
+ # return
$self -> {metaon} . $name . $self -> {metaoff};
}
-################################
-# sub list
+### sub list ###################################################################
+#
+# fill in a complete list
+#
+# Params: $name - name of the atomic scrap
+# $array - list of hashes (same strcuture like the hash used by 'scrap')
+#
+# Return: scalar reference - filled in list
#
-# komplette Liste einsetzen
-################################
-
sub list {
- my $self=shift;
- my $name=shift;
+ my $self = shift;
+ my $name = shift;
- croak "no template file specified" unless (defined $self->{file});
+ croak "no template file specified"
+ unless (defined $self -> {file});
- my $list = join '', map { ${ $self -> scrap ($name, $_) } } @{ +shift };
+# no warnings 'uninitialized';
+ my $list = join '' => map { ${ $self -> scrap ($name, $_) } } @{ +shift };
- # Rueckgabe
+ # return
\$list;
}
-################################
-# sub scrap
+### sub scrap ##################################################################
+#
+# fill in a template scrap
+#
+# Params: $name - name of the scrap
+#
+# Return: scalar reference - filled in scrap
#
-# Schnipsel ausfuellen
-################################
-
sub scrap {
- my $self=shift;
- my $name=shift;
-
- croak "no template file specified" unless (defined $self->{file});
-
- my %params;
+ my $self = shift;
+ my $name = shift;
- # Parameter holen
- # Als Values werden nur die Referenzen gespeichert
- %params = map { my $ref = $_; map { ($_ => ( (ref ($ref -> {$_} ) )?$ref -> {$_}: \($ref -> {$_} ) ) ) } keys %$ref } splice @_;
+ croak "no template file specified"
+ unless (defined $self -> {file});
- # und einsetzen
- my $scrap=$self->{parsed}->{$name};
- my $qmon=quotemeta $self->{metaon};
- my $qmoff=quotemeta $self->{metaoff};
+ return \'' unless (defined $name and defined ($self -> {parsed} -> {$name}));
- # und zwar solange, bis nichts mehr da ist
- while ($scrap =~ s<$qmon\s*([_a-zA-Z]\S*)\s*$qmoff>[
- my $x='';
- if ( exists ( $params{$1} ) ) { $x = ${$params{$1}} }
- elsif (exists ( $self -> {parsed} -> {$1} ) ) { $x = $self -> {parsed} -> {$1}}
- $x;]geo ){};
+ # fetch parameters
+ # (and normalize - save only the references in %params)
+ #
+ my %params;
+ %params = map {
+ my $ref = $_;
+ map {
+ ($_ => (
+ ref ($ref -> {$_})
+ ? (defined ${$ref -> {$_}} ? $ref -> {$_} : \'')
+ : \(defined $ref -> {$_} ? $ref -> {$_} : ''))
+ )
+ } keys %$ref
+ } splice @_;
+
+ # fill in...
+ #
+ my $scrap = $self -> {parsed} -> {$name};
+ my $qmon = quotemeta $self -> {metaon};
+ my $qmoff = quotemeta $self -> {metaoff};
- $self -> parse_if (\$scrap,\%params);
+ # ...until we've replaced all placeholders
+ #
+ 1 while (
+ $scrap =~ s
+ <
+ $qmon \s*
+ ([_a-zA-Z] \S*)
+ \s* $qmoff
+ >
+ [ (exists ( $params{$1} ) )
+ ? ${$params{$1}}
+ : ( exists ( $self -> {parsed} -> {$1} )
+ ? $self -> {parsed} -> {$1}
+ : ''
+ );
+ ]gex
+ );
+
+ # parse conditional blocks
+ #
+ $self -> parse_if (
+ \$scrap,
+ \%params
+ );
- # Rueckgabe
+ # return
\$scrap;
}
-# ====================================================
-# Private Funktionen/Methoden
-# ====================================================
-
-################################
-# sub parse_file
+### sub parse_file #############################################################
+#
+# read in and parse template file
+#
+# Params: ~none~
+#
+# Return: Status Code (Boolean)
#
-# Template einlesen & parsen
-################################
-
sub parse_file {
my $self = shift;
+ my $filename = $self -> {file};
+
+ if ($xml_dom_used) {
- if (-f $self -> {file}) {
- my $filename = $self -> {file};
+ # parse template using XML::DOM
+ #
my $xml = eval {
local $SIG{__DIE__};
new XML::DOM::Parser -> parsefile ($filename);
};
- croak "error in template file '$filename': $@" if ($@);
+ croak "error while parsing template file '$filename': $@" if ($@);
my $template = $xml -> getElementsByTagName ('Template', 0) -> item (0);
- # Metas bestimmen
+ # extract meta delimiters
+ #
$self -> {metaon} = $template -> getAttribute ('metaon');
$self -> {metaoff} = $template -> getAttribute ('metaoff');
$self -> {parsed} -> {$name} = $_ -> getFirstChild -> getData;
$self -> {parsed} -> {$name} =~ s/^\s+|\s+$//g;}
- return 1; # alles klar
+ return 1; # looks fine
+ }
+ else {
+ # XML::DOM not available...
+ # parse the template using both hands ;)
+ #
+
+ my ($xml, $root, $template);
+ local (*FILE, $/);
+
+ open FILE, "< $filename" or croak "error while reading template file '$filename': $!";
+ $xml = <FILE>;
+ close FILE or croak "error while closing template file '$filename' after reading: $!";
+
+ ($root, $template) = ($1, $2) if ($xml =~ m|(<Template\s+[^>"]*(?:"[^"]*"[^>"]*)*>)(.*)</Template\s*>|s);
+ croak "error while parsing template file '$filename': missing root element 'Template'"
+ unless (defined $root and defined $template);
+
+ # extract meta delimiters
+ #
+ $self -> {metaon} = $1 if ($root =~ /\smetaon\s*=\s*"([^"]+)"/);
+ $self -> {metaoff} = $1 if ($root =~ /\smetaoff\s*=\s*"([^"]+)"/);
+
+ croak "missing meta defintion(s) in template file '$filename'." unless ($self -> {metaon} and $self -> {metaoff});
+
+ # don't use any other entities than " ' < > and &
+ # (while using non XML::DOM - version)
+ #
+ for ('metaon', 'metaoff') {
+ $self -> {$_} =~ s/"/"/g; $self -> {$_} =~ s/'/'/g;
+ $self -> {$_} =~ s/</</g; $self -> {$_} =~ s/>/>/g;
+ $self -> {$_} =~ s/&/&/g;
+ }
+
+ $self -> {parsed} = {};
+ while ($template =~ m|<Scrap\s+(?:id\s*=\s*"([^"]+)")?\s*>\s*<!\[CDATA\[([^\]]*(?:\](?!\]>)[^\]]*)*)\]\]>\s*</Scrap\s*>|g) {
+
+ my ($name, $content) = ($1, $2);
+
+ croak "Element 'Scrap' requires attribute 'id' in template file '$filename'"
+ unless (defined $name and length $name);
+
+ croak "double defined id '$name' in template file '$filename'"
+ if (exists ($self -> {parsed} -> {$name}));
+
+ croak "use '/^[_a-zA-Z]\\S*\$/' for 'Scrap'-ids in template file '$filename' (wrong: '$name')"
+ unless ($name =~ /^[_a-zA-Z]\S*$/);
+
+ $content =~ s/^\s+//; $content =~ s/\s+$//;
+ $self -> {parsed} -> {$name} = $content;
+ }
+
+ return 1; # looks fine
}
- 0;
+ return; # anything failed (??)
}
-################################
-# sub parse_if
+### sub parse_if ###############################################################
+#
+# parse conditional blocks
+#
+# Params: $scrap - scalar reference of the template scrap
+# $params - hash reference: values from the application
+#
+# Return: ~none~, ($$scrap will be modified)
#
-# %IF - Anweisungen parsen
-################################
-
sub parse_if {
my $self = shift;
my ($scrap, $params) = @_;
my $qmon = quotemeta $self -> {metaon};
my $qmoff = quotemeta $self -> {metaoff};
- # der folgende Regex ist ein bisschen fies ...
- # ... aber er funktioniert :-)
- #
- # pfff - rekursive Strukturen iterativ parsen ist nicht wirklich witzig
- #
+ # the following regex is just not optimized,
+ # but it works ;)
1 while ($$scrap =~ s {
- ($qmon\s*%(?:IF|ELSE)\s+.+?\s*$qmoff.*?) # Wenn IF oder ELSE von
- (?=$qmon\s*%IF\s+.+?\s*$qmoff) # IF gefolgt werden, soll
- # dieses Stueck uebersprungen
- # werden und erstmal mit der
- # naechsten Ebene weitergemacht
- # werden.
-
- |( # hier beginnt $2
- $qmon\s*%IF\s+(.+?)\s*$qmoff # IF
+ ($qmon\s*%(?:IF|ELSE)\s+.+?\s*$qmoff.*?) # skip this part
+ (?=$qmon\s*%IF\s+.+?\s*$qmoff) # if %IF or %ELSE are followed by %IF
+
+ |( # $2 starts here
+ $qmon\s*%IF\s+(.+?)\s*$qmoff # %IF
(.*?) # $4
(?:
- $qmon\s*%ENDIF\s*$qmoff # gefolgt von ENDIF
- | # oder
- $qmon\s*%ELSE\s*$qmoff # von ELSE... ($4 ELSE $5)
- (.*?)
- $qmon\s*%ENDIF\s*$qmoff # und ENDIF
+ $qmon\s*%ENDIF\s*$qmoff # followed by %ENDIF
+ | # or
+ $qmon\s*%ELSE\s*$qmoff # %ELSE...
+ (.*?) # $5
+ $qmon\s*%ENDIF\s*$qmoff # ...and ENDIF
)
)
}
for (split /\s+/,$t3) {
next unless (
exists($params->{$_})
+ and defined ${$params->{$_}}
and length ${$params->{$_}}
);
}
$ret;
- }gosex);
+ }gsex);
return;
}
-# keep require happy
+# keeping 'require' happy
1;
#
#
-### end of Template ############################################################
+### end of Template ############################################################
\ No newline at end of file
-# Template/Forum.pm
+package Template::Forum;
-# ====================================================
-# Autor: n.d.p. / 2001-01-12
-# lm : n.d.p. / 2001-01-12
-# ====================================================
-# Funktion:
-# Erzeugung der HTML-Ausgabe der
-# Forumshauptdatei
-# ====================================================
+################################################################################
+# #
+# File: shared/Template/Forum.pm #
+# #
+# Authors: André Malo <nd@o3media.de>, 2001-04-19 #
+# #
+# Description: print Forum main file to STDOUT #
+# #
+################################################################################
use strict;
-package Template::Forum;
-
use Lock qw(:READ);
use Encode::Plain; $Encode::Plain::utf8 = 1;
use Posting::_lib qw(get_all_threads long_hr_time);
use Template::_conf;
use Template::_thread;
-# ====================================================
-# Funktionsexport
-# ====================================================
-
+################################################################################
+#
+# Export
+#
use base qw(Exporter);
@Template::Forum::EXPORT = qw(print_forum_as_HTML);
-################################
-# sub print_forum_as_HTML
+### sub print_forum_as_HTML ($$$) ##############################################
+#
+# print Forum main file to STDOUT
+#
+# Params: $mainfile - main xml file name
+# $tempfile - template file name
+# $param - hash reference (see doc for details)
+#
+# Return: ~none~
#
-# HTML erstellen
-################################
-
sub print_forum_as_HTML ($$$) {
my ($mainfile, $tempfile, $param) = @_;
my $assign = $param -> {assign};
my ($threads, $stat);
unless ($stat = lock_file ($mainfile)) {
- if ($stat == 0) {
+ if (defined $stat) {
violent_unlock_file ($mainfile);
- print "aha!"
- # ueberlastet
+ print ${$template -> scrap (
+ $assign -> {errorDoc},
+ { $assign -> {errorText} => $template -> insert ($assign -> {'occupied'}) }
+ )};
}
-
else {
- # Mastersperre...
+ print ${$template -> scrap (
+ $assign -> {errorDoc},
+ { $assign -> {errorText} => $template -> insert ($assign -> {'notAvailable'}) }
+ )};
}}
else {
- my $view = get_view_params ({adminDefault => $param -> {adminDefault}
- });
+ my $view = get_view_params (
+ { adminDefault => $param -> {adminDefault} }
+ );
$threads = get_all_threads ($mainfile, $param -> {showDeleted}, $view -> {sortedMsg});
violent_unlock_file ($mainfile) unless (unlock_file ($mainfile));
- print ${$template -> scrap ($assign -> {mainDocStart},
- {$assign -> {loadingTime} => plain (long_hr_time (time)) } )},"\n<dl>";
+ print ${$template -> scrap (
+ $assign -> {mainDocStart},
+ { $assign -> {loadingTime} => plain (long_hr_time (time)) }
+ )
+ },"\n<dl>";
- my $tpar = {template => $param -> {tree},
- cgi => $param -> {cgi},
- start => -1};
+ my $tpar = {
+ template => $param -> {tree},
+ cgi => $param -> {cgi},
+ start => -1
+ };
my @threads;
return;
}
-# ====================================================
-# Modulinitialisierung
-# ====================================================
-
-# making require happy
+# keep require happy
1;
-# ====================================================
-# end of Template::Forum
-# ====================================================
\ No newline at end of file
+#
+#
+### end of Template::Forum #####################################################
my ($threadpath, $tempfile, $param) = @_;
my $template = new Template $tempfile;
+ my $assign = $param -> {assign};
- # Datei sperren... (eigentlich)
my $view = get_view_params ({
adminDefault => $param -> {adminDefault}
});
- my $xml = parse_xml_file ($threadpath.'t'.$param -> {thread}.'.xml');
-
- my ($mnode, $tnode) = get_message_node ($xml, 't'.$param -> {thread}, 'm'.$param -> {posting});
- my $pnode = $mnode -> getParentNode;
- my $header = get_message_header ($mnode);
- my $msg = parse_single_thread ($tnode, $param -> {showDeleted}, $view -> {sortedMsg});
- my $pheader = ($pnode -> getNodeName eq 'Message')?get_message_header ($pnode):{};
-
- my $assign = $param -> {assign};
- my $formdata = $param -> {form} -> {data};
- my $formact = $param -> {form} -> {action};
-
- my $body = get_message_body ($xml, 'm'.$param -> {posting});
-
- my $text = message_field (
- $body,
- { quoteChars => plain($view -> {quoteChars}),
- quoting => 1,
- startCite => ${$template -> scrap ($assign -> {startCite})},
- endCite => ${$template -> scrap ($assign -> {endCite})}
+ my ($xmlfile, $locked, $xml) = ($threadpath.'t'.$param -> {thread}.'.xml', 0);
+
+ unless (($locked = lock_file ($xmlfile)) and ($xml = parse_xml_file ($xmlfile))) {
+ violent_unlock_file ($xmlfile);
+ print ${$template -> scrap (
+ $assign -> {errorDoc},
+ { $assign -> {errorText} => $template -> insert (
+ $assign -> {(defined $locked)
+ ? 'occupied'
+ : 'notAvailable'
+ })
+ }
+ )};
+ }
+ else {
+ violent_unlock_file ($xmlfile) unless (unlock_file($xmlfile));
+
+ my ($mnode, $tnode) = get_message_node ($xml, 't'.$param -> {thread}, 'm'.$param -> {posting});
+
+ unless ($mnode and not $mnode->getAttribute('invisible')) {
+ print ${$template -> scrap (
+ $assign -> {errorDoc},
+ { $assign -> {errorText} => $template -> insert ($assign -> {'notAvailable'}) }
+ )};
}
- );
-
- my $area = answer_field (
- $body,
- { quoteArea => 1,
- quoteChars => plain($view -> {quoteChars}),
- messages => $param -> {messages}
+ else {
+ my $pnode = $mnode -> getParentNode;
+ my $header = get_message_header ($mnode);
+ my $msg = parse_single_thread ($tnode, $param -> {showDeleted}, $view -> {sortedMsg});
+ my $pheader = ($pnode -> getNodeName eq 'Message')?get_message_header ($pnode):{};
+
+ my $formdata = $param -> {form} -> {data};
+ my $formact = $param -> {form} -> {action};
+
+ my $body = get_message_body ($xml, 'm'.$param -> {posting});
+
+ my $text = message_field (
+ $body,
+ { quoteChars => plain($view -> {quoteChars}),
+ quoting => $view -> {quoting},
+ startCite => ${$template -> scrap ($assign -> {startCite})},
+ endCite => ${$template -> scrap ($assign -> {endCite})}
+ }
+ );
+
+ my $area = answer_field (
+ $body,
+ { quoteArea => 1,
+ quoteChars => plain($view -> {quoteChars}),
+ messages => $param -> {messages}
+ }
+ );
+
+ my $pars = {};
+
+ $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name})
+ for (qw(
+ posterBody
+ uniqueID
+ followUp
+ quoteChar
+ userID
+ posterName
+ posterEmail
+ posterURL
+ posterImage
+ )
+ );
+
+ my $cgi = $param -> {cgi};
+
+ my $tpar = {
+ thread => $param -> {thread},
+ template => $param -> {tree},
+ start => $param -> {posting},
+ cgi => $cgi
+ };
+
+ my $parent_pars;
+
+ $parent_pars = {
+ $assign->{parentTitle} => plain(defined $pheader->{subject} ? $pheader->{subject} : ''),
+ $assign->{parentCat} => plain(defined $pheader->{category} ? $pheader->{category} : ''),
+ $assign->{parentName} => plain(defined $pheader->{name} ? $pheader->{name} : ''),
+ $assign->{parentTime} => plain(hr_time($pheader->{time})),
+ $assign->{parentLink} => query_string (
+ { $cgi -> {thread} => $param -> {thread},
+ $cgi -> {posting} => ($pnode -> getAttribute ('id') =~ /(\d+)/)[0]
+ })
+ } if (%$pheader);
+
+ print ${$template -> scrap (
+ $assign->{mainDoc},
+ { $assign->{name} => plain(defined $header->{name} ? $header->{name} : ''),
+ $assign->{email} => plain(defined $header->{email} ? $header->{email} : ''),
+ $assign->{home} => plain(defined $header->{home} ? $header->{home} : ''),
+ $assign->{image} => plain(defined $header->{image} ? $header->{image} : ''),
+ $assign->{time} => plain(hr_time($header->{time})),
+ $assign->{message} => $text,
+ $assign->{messageTitle} => plain(defined $header->{subject} ? $header->{subject} : ''),
+ $assign->{messageCat} => plain(defined $header->{category} ? $header->{category} : ''),
+ $param->{tree}->{main} => html_thread ($msg, $template, $tpar),
+ $formact->{post}->{assign} => $formact->{post}->{url},
+ $formact->{vote}->{assign} => $formact->{vote}->{url},
+ $formdata->{posterBody}->{assign}->{value} => $area,
+ $formdata->{uniqueID} ->{assign}->{value} => plain(unique_id),
+ $formdata->{followUp} ->{assign}->{value} => plain($param -> {thread}.';'.$param -> {posting}),
+ $formdata->{quoteChar} ->{assign}->{value} => "ÿ".plain(defined $view -> {quoteChars} ? $view -> {quoteChars} : ''),
+ $formdata->{userID} ->{assign}->{value} => ''
+ },
+ $pars,
+ $parent_pars
+ )};
}
- );
-
- my $pars = {};
-
- $pars -> {$formdata -> {$_} -> {assign} -> {name}} = plain($formdata -> {$_} -> {name})
- for (qw(
- posterBody
- uniqueID
- followUp
- quoteChar
- userID
- posterName
- posterEmail
- posterURL
- posterImage
- ));
-
- my $cgi = $param -> {cgi};
-
- my $tpar = {
- thread => $param -> {thread},
- template => $param -> {tree},
- start => $param -> {posting},
- cgi => $cgi
- };
-
- my $parent_pars;
-
- $parent_pars = {
- $assign->{parentTitle} => plain($pheader->{subject}),
- $assign->{parentCat} => plain($pheader->{category}),
- $assign->{parentName} => plain($pheader->{name}),
- $assign->{parentTime} => plain(hr_time($pheader->{time})),
- $assign->{parentLink} => query_string (
- { $cgi -> {thread} => $param -> {thread},
- $cgi -> {posting} => ($pnode -> getAttribute ('id') =~ /(\d+)/)[0]
- })
- } if (%$pheader);
-
- print ${$template -> scrap (
- $assign->{mainDoc},
- { $assign->{name} => plain($header->{name}),
- $assign->{email} => plain($header->{email}),
- $assign->{home} => plain($header->{home}),
- $assign->{image} => plain($header->{image}),
- $assign->{time} => plain(hr_time($header->{time})),
- $assign->{message} => $text,
- $assign->{messageTitle} => plain($header->{subject}),
- $assign->{messageCat} => plain($header->{category}),
- $param->{tree}->{main} => html_thread ($msg, $template, $tpar),
- $formact->{post}->{assign} => $formact->{post}->{url},
- $formact->{vote}->{assign} => $formact->{vote}->{url},
- $formdata->{posterBody}->{assign}->{value} => $area,
- $formdata->{uniqueID} ->{assign}->{value} => plain(unique_id),
- $formdata->{followUp} ->{assign}->{value} => plain($param -> {thread}.';'.$param -> {posting}),
- $formdata->{quoteChar} ->{assign}->{value} => "ÿ".plain($view -> {quoteChars}),
- $formdata->{userID} ->{assign}->{value} => ''
- },
- $pars,
- $parent_pars
- )};
+ }
return;
}
#
#
-### end of Template::Posting ###################################################
-
+### end of Template::Posting ###################################################
\ No newline at end of file
my $default = $param -> {adminDefault};
my %hash;
- %hash = (quoteChars => $default -> {View} -> {quoteChars},
- sortedMsg => $default -> {View} -> {sortMessages},
+ %hash = (quoting => $default -> {View} -> {quoting},
+ quoteChars => $default -> {View} -> {quoteChars},
+ sortedMsg => $default -> {View} -> {sortMessages},
sortedThreads => $default -> {View} -> {sortThreads}
);
-->
<Scrap id="CITE_START"><![CDATA[ <span style="color:#800000;"> ]]></Scrap>
-<Scrap id="CITE_END"><![CDATA[ </span><br> ]]></Scrap>
+<Scrap id="CITE_END"><![CDATA[ </span> ]]></Scrap>
<!--
Links/URLs
<Variable name="mainDocEnd">DOC_FORUM_END</Variable>
<Variable name="loadingTime">_LOAD_TIME</Variable>
<Variable name="cssFile">_CSS_FILE</Variable>
+ <Variable name="errorDoc">DOC_ERROR</Variable>
+ <Variable name="startCite">CITE_START</Variable>
+ <Variable name="endCite">CITE_END</Variable>
+
+ <Variable name="notAvailable">_N_A</Variable>
+ <Variable name="occupied">_OCCUPIED</Variable>
+ <Variable name="errorText">_ERROR_TEXT</Variable>
</Property>
</Property>
<Property name="assign">
<Variable name="mainDoc">DOC_POSTING</Variable>
+ <Variable name="errorDoc">DOC_ERROR</Variable>
<Variable name="cssFile">_CSS_FILE</Variable>
<Variable name="message">_MESSAGE</Variable>
<Variable name="name">_BEF_NAME</Variable>
<Variable name="parentLink">_REF_LINK</Variable>
<Variable name="startCite">CITE_START</Variable>
<Variable name="endCite">CITE_END</Variable>
+
+ <Variable name="notAvailable">_N_A</Variable>
+ <Variable name="occupied">_OCCUPIED</Variable>
+ <Variable name="errorText">_ERROR_TEXT</Variable>
</Property>
<Property name="form">
</html>
]]></Scrap>
- <Scrap id="TREE_CLOSED"><![CDATA[
-<a href="{&& _COMMAND &&}">{&& IMG_XCLOSED &&}</a> (<b>{&& _CATEGORY &&}</b>) <a href="{&& _LINK &&}"><b>{&& _TITLE &&}</b></a> von <b>{&& _NAME &&}</b>, {&& _TIME &&}
- ]]></Scrap>
+<Scrap id="_N_A"><![CDATA[Das Forum ist zur Zeit aus Wartungsgründen geschlossen. Versuchen Sie es bitte später nocheinmal.]]></Scrap>
+<Scrap id="_OCCUPIED"><![CDATA[Das Forum ist temporär nicht verfügbar. Versuchen Sie es bitte in einigen Minuten nocheinmal.]]></Scrap>
+
+ <Scrap id="DOC_ERROR"><![CDATA[
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+
+<html>
+<head>
+ <meta http-equiv="expires" content="0">
+ <meta name="robots" content="noindex">
+
+ <title>SELFHTML Forum: Fehler</title>
+
+ <link rel="stylesheet" type="text/css" href="{&& _CSS_FILE &&}">
+</head>
- <Scrap id="TREE_CLOSED_NC"><![CDATA[
-<a href="{&& _COMMAND &&}">{&& IMG_XCLOSED &&}</a> <a href="{&& _LINK &&}"><b>{&& _TITLE &&}</b></a> von <b>{&& _NAME &&}</b>, {&& _TIME &&}
+<body bgcolor="#FFFFFF" text="#000000" link="#AA5522" vlink="#772200" alink="#000000">
+<table cellpadding="4" cellspacing="0" border="0" width="100%"><tr><td bgcolor="#FFEEDD" class="nav"><a class="an" name="top">{&& IMG_X2 &&}</a> {&& LINK_SELFAKTUELL &&} {&& IMG_X2 &&} {&& LINK_SELFLIVE &&} {&& IMG_X2 &&} {&& LINK_SELFFORUM &&}</td></tr></table><table cellpadding="4" cellspacing="0" border="0" width="100%">
+<tr><td bgcolor="#EEEEEE" class="doc" width="110">{&& IMG_XWEB &&}</td>
+ <td bgcolor="#EEEEEE" class="doc" valign="bottom" width="100%"><h2>SELFHTML Forum:<br>Fehler</h2></td></tr>
+<tr><td bgcolor="#EEEEEE" class="doc" valign="top" align="center">{&& IMG_X5 &&}</td>
+ <td bgcolor="#FFFFFF" valign="top">
+ <p>{&& IMG_XGDOWN &&} <a href="#a1"><b>Fehler</b></a></p></td></tr>
+<tr><td colspan="2" bgcolor="#EEEEEE" class="doc"><a href="#bottom">{&& IMG_XGDOWN &&}</a> </td></tr>
+</table>
+<h2 class="Sh2"><a class="an" name="a1">Fehler</a></h2>
+<p>{&& _ERROR_TEXT &&}</p>
+<table cellpadding="4" cellspacing="0" border="0" width="100%">
+<tr><td bgcolor="#EEEEEE" class="doc"><a href="#top">{&& IMG_XGOUP &&}</a></td></tr>
+<tr><td bgcolor="#FFEEDD" class="nav"><a class="an" name="bottom">{&& IMG_X2 &&}</a> {&& LINK_SELFAKTUELL &&} {&& IMG_X2 &&} {&& LINK_SELFLIVE &&} {&& IMG_X2 &&} {&& LINK_SELFFORUM &&}</td></tr>
+</table>
+<p>© 2000 {&& IMG_XGMAIL &&} <a href="mailto:{&& MAIL_SELF &&}">{&& MAIL_SELF &&}</a></p>
+</body>
+</html>
]]></Scrap>
<Scrap id="TREE_START"><![CDATA[
</html>
]]></Scrap>
+<Scrap id="_N_A"><![CDATA[Das angeforderte Posting ist nicht verfügbar.]]></Scrap>
+<Scrap id="_OCCUPIED"><![CDATA[Das angeforderte Posting ist temporär nicht verfügbar. Versuchen Sie es bitte in einigen Minuten nocheinmal.]]></Scrap>
+
+ <Scrap id="DOC_ERROR"><![CDATA[
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+
+<html>
+<head>
+ <meta http-equiv="expires" content="0">
+ <meta name="robots" content="noindex">
+
+ <title>SELFHTML Forum: Fehler</title>
+
+ <link rel="stylesheet" type="text/css" href="{&& _CSS_FILE &&}">
+</head>
+
+<body bgcolor="#FFFFFF" text="#000000" link="#AA5522" vlink="#772200" alink="#000000">
+<table cellpadding="4" cellspacing="0" border="0" width="100%"><tr><td bgcolor="#FFEEDD" class="nav"><a class="an" name="top">{&& IMG_X2 &&}</a> {&& LINK_SELFAKTUELL &&} {&& IMG_X2 &&} {&& LINK_SELFLIVE &&} {&& IMG_X2 &&} {&& LINK_SELFFORUM &&}</td></tr></table><table cellpadding="4" cellspacing="0" border="0" width="100%">
+<tr><td bgcolor="#EEEEEE" class="doc" width="110">{&& IMG_XWEB &&}</td>
+ <td bgcolor="#EEEEEE" class="doc" valign="bottom" width="100%"><h2>SELFHTML Forum:<br>Fehler</h2></td></tr>
+<tr><td bgcolor="#EEEEEE" class="doc" valign="top" align="center">{&& IMG_X5 &&}</td>
+ <td bgcolor="#FFFFFF" valign="top">
+ <p>{&& IMG_XGDOWN &&} <a href="#a1"><b>Fehler</b></a></p></td></tr>
+<tr><td colspan="2" bgcolor="#EEEEEE" class="doc"><a href="#bottom">{&& IMG_XGDOWN &&}</a> </td></tr>
+</table>
+<h2 class="Sh2"><a class="an" name="a1">Fehler</a></h2>
+<p>{&& _ERROR_TEXT &&}</p>
+<table cellpadding="4" cellspacing="0" border="0" width="100%">
+<tr><td bgcolor="#EEEEEE" class="doc"><a href="#top">{&& IMG_XGOUP &&}</a></td></tr>
+<tr><td bgcolor="#FFEEDD" class="nav"><a class="an" name="bottom">{&& IMG_X2 &&}</a> {&& LINK_SELFAKTUELL &&} {&& IMG_X2 &&} {&& LINK_SELFLIVE &&} {&& IMG_X2 &&} {&& LINK_SELFFORUM &&}</td></tr>
+</table>
+<p>© 2000 {&& IMG_XGMAIL &&} <a href="mailto:{&& MAIL_SELF &&}">{&& MAIL_SELF &&}</a></p>
+</body>
+</html>
+ ]]></Scrap>
<!--
***** Schnipsel *****
lastMessage => $f -> {last_message},
parsedThreads => $f -> {threads},
dtd => $f -> {dtd},
- messages => $self -> {template} -> {messages} || {},
+ messages => $self -> {conf} -> {template} -> {messages} || {},
+ base_uri => $self -> {conf} -> {original} -> {files} -> {forum_base}
};
# set the variables if defined..
#
$self -> {response} -> {doc} = $self -> {conf} -> {assign} -> {docThx};
$self -> {response} -> {pars} = {
- $thx -> {time} => plain (hr_time($time)),
- $thx -> {body} => message_as_HTML (
+ $thx -> {time} => plain (hr_time($time)),
+ $thx -> {body} => message_as_HTML (
$xml,
$self -> {template},
{ posting => $mid,
my $lock_stat;
unless ($lock_stat = write_lock_file ($self -> {conf} -> {forum_file_name})) {
- if (defined $lock_stat and $lock_stat == 0) {
+ if (defined $lock_stat) {
# occupied or no w-bit set for the directory..., hmmm
#
violent_unlock_file ($self -> {conf} -> {forum_file_name});
thread => $tid,
posting => $mid,
adminDefault => $adminDefault,
- messages => $show_posting -> {messages},
+ messages => $conf -> {template} -> {messages},
form => $show_posting -> {form},
cgi => $cgi,
tree => $tree
git.p6c8.net / selfforum.git / commitdiff