#! /usr/bin/perl
use warnings;
use strict;
use CGI ();
use HTML::Entities();
use Regexp::Common qw(balanced);
use URI::Find::Schemeless ();

$| = 1;    # no suffering from buffering

use vars qw(%TagsBlocked %TagsFastReplace %TagsLastReplace $HighlightBin);

# use external program from
# http://gnu.j1b.org/software/src-highlite/source-highlight.html
$HighlightBin = 'E:\apps\gnu\src-highlight\bin\source-highlight.exe';

# tags within which no further replacements should be done

# better replacing the font stuff by CSS
%TagsBlocked = (
    perle => {
        -start => qq~<br><b>PERL:</b>
			<table border="0" width="95%" cellpadding="8"><tr><td bgcolor="dddddd">
			<font face="Courier New, Courier, mono">~,
        -end    => qq~</font></td></tr></table>~,
        -string => \&HighlightPerlCode,
    },
    code => {
        -start => qq~<br><b>CODE:</b>
			<table border="0" width="95%" cellpadding="4"><tr><td bgcolor="dddddd">
			<font face="Courier New, Courier, mono">~,
        -end    => qq~</font></td></tr></table>~,
        -string => sub { return $_[0] },
    },
    perldoc => {
        -start  => "",
        -end    => "",
        -string => sub {
            return qq~ <a href="http://url/$_[0]">perldoc $_[0]</a> ~;
        },
    },
);

# tags to be replaced on the fly
%TagsFastReplace = (
    b => {
        -start  => "<b>",
        -end    => "</b>",
        -string => sub { return $_[0] },
    },
    i => {
        -start  => "<i>",
        -end    => "</i>",
        -string => sub { return $_[0] },
    },
);

# tags that may be recursive or containing other tags
%TagsLastReplace = (
    quote => {
        -start =>
          qq~<div align="center"><table border="1" width="95%"><tr><td>~,
        -end    => qq~</td></tr></table></div>~,
        -string => sub { return $_[0] },
    },
);

{
    local $/;    # slurp in data
    my $posting = <DATA>;

    &ParseText($posting);
}

# ------------------------------------------------------------
sub ParseText {
    my ($text) = @_;

    $text = &CGI::escapeHTML($text);
    $text =~ s/\n/<br>\n/g;    # replace newlines by <br>

    my @scanned = ();

    # extract and replace %TagsBlocked
    foreach my $tag ( keys %TagsBlocked ) {

        # @scanned yet empty, start with $text
        unless ( scalar(@scanned) ) {
            @scanned = &PostFilterBlocked( $text, $tag );
        }                      # unless

        # @scanned filled, start scanning the rest
        else {
            my @scanned2 = ();    # temporary variable
            foreach (@scanned) {

                # skip already scanned parts
                push ( @scanned2, $_ ), next if ref($_);

                # scan only if scalar
                push ( @scanned2, &PostFilterBlocked( $_, $tag ) );

            }                     # foreach
            @scanned = @scanned2;
        }    # else
    }    # foreach

    # replace %TagsFastReplace
    foreach my $tag ( keys %TagsFastReplace ) {

        # @scanned yet empty, start with $text
        unless ( scalar(@scanned) ) {
            @scanned = &PostFilterFastReplace( $text, $tag );
        }    # unless

        # @scanned filled, start scanning the rest
        else {
            my @scanned2 = ();    # temporary variable
            foreach (@scanned) {

                # skip already scanned parts
                push ( @scanned2, $_ ), next if ref($_);

                # scan only if scalar
                push ( @scanned2, &PostFilterFastReplace( $_, $tag ) );

            }                     # foreach
            @scanned = @scanned2;
        }    # else
    }    # foreach

    # prepare finder sub for replacing URIs in Text with HTML-Links
    my $uriFinder = URI::Find::Schemeless->new(
        sub {
            return qq~<a href=\"~
              . &HTML::Entities::encode_entities("$_[0]")
              . qq~\" target="_blank">~
              . &HTML::Entities::encode_entities( $_[1] ) . '</a>';
        }
    );

    # replace URIs in Text with HTML-Links
    ref($_) or $uriFinder->find( \$_ ) foreach @scanned;

    # build string and replace code/perl/...-tags with [\0\0$tag]
    # to prevent further parsing
    my $string = join (
        "",
        map {
            ref($_)
              ? map {
                my $r = $_;
                $r =~ s/(\[)(.+\])/$1."\0\0".$2/gse;
                $r;
              } values( %{$_} )
              : $_;
          } @scanned
    );

    # replace stuff that might contain other tags (like quote)
    foreach my $tag ( keys %TagsLastReplace ) {
        $string = &PostFilterLastReplace( $string, $tag );
    }    # foreach

    $string =~ s/\0\0//g;    # remove \0\0 (from [\0\0$tag])
    print "\n\n", $string;

}    # ParseText

# ------------------------------------------------------------
sub PostFilterBlocked {
    my ( $text, $tag ) = @_;

    my $startLength = length("[$tag]");
    my $endLength   = length("[/$tag]");

    my @scanned = ();

    my $startPos = index( $text, "[$tag]" );
    my $lastPos  = 0;

    print "\nScanning for tag [$tag]";
    while ( $startPos != -1 ) {
        print " $startPos";

        # add leading part to @scanned
        my $string = substr( $text, $lastPos, $startPos - $lastPos );
        push ( @scanned, $string ) if length $string;

        # check if [$tag]...[/$tag]-block found
        $lastPos = index( $text, "[/$tag]", $startPos + $startLength );
        print "-$lastPos";
        unless ( $lastPos == -1 ) {    # if found

            # push reference to @scanned: { $tag => $string }
            my $string = substr(
                $text,
                $startPos + $startLength,
                $lastPos - $startPos - $startLength
            );
            $string =~ s/^\r?\n//g;
            $string =~ s/\r?\n$//g;

            # replace tags with replacement
            $string =
              $TagsBlocked{ lc($tag) }->{ -start }
              . $TagsBlocked{ lc($tag) }->{ -string }->($string)
              . $TagsBlocked{ lc($tag) }->{ -end };

            # add to queue as reference
            push ( @scanned, { $tag => $string } ) unless $string =~ /^\s*$/;

        }    # if

        else {    # if not found

            # push rest of $text to @scanned (as string)
            my $string = substr( $text, $startPos, length($text) - $startPos );

            # if last line was in @TagsBlocked, add new array element
            if ( ref $scanned[-1] ) {
                push ( @scanned, $string ) if length $string;
            }

            # if not, append as text to the last element
            else {
                $scanned[-1] .= $string;
            }    # else

            last;    # and exit while

        }    # else

        # (re-)initialize next search position
        $lastPos += $endLength;

        # search for next [tag]
        $startPos = index( $text, "[$tag]", $lastPos );

    }    # while

    # care for rest of $text
    if ( $lastPos != -1 ) {
        my $string = substr( $text, $lastPos, length($text) - $lastPos );
        push ( @scanned, $string ) if length($string);
    }    # if

    return @scanned;
}    # PostFilterBlocked

# ------------------------------------------------------------
sub PostFilterFastReplace {
    my ( $text, $tag ) = @_;
    print "\nScanning for tag [$tag]";

    my $startLength = length("[$tag]");
    my $endLength   = length("[/$tag]");

    my @scanned = ();

    while (
        $text =~ s/
	    \[\Q$tag\E\]
	    (.+?)
	    \[\/\Q$tag\E\]
	    /
	    $TagsFastReplace{lc($tag)}->{-start} .
	    $TagsFastReplace{lc($tag)}->{-string}->($1) .
	    $TagsFastReplace{lc($tag)}->{-end}
	    /xseig
      )
    {
        1;
    }    # while

    return $text;
}    # PostFilterFastReplace

# ------------------------------------------------------------
sub PostFilterLastReplace {
    my ( $string, $tag ) = @_;
    print "\nScanning for tag [$tag]";

    my $startLength = length("[$tag]");
    my $endLength   = length("[/$tag]");

    1 while $string =~ s!
	$RE{balanced}{-begin => "[$tag]"}{-end => "[/$tag]"}{-keep}
    !
 	$TagsLastReplace{lc($tag)}->{-start} .
	$TagsLastReplace{lc($tag)}->{-string}->
	(substr ($1, $startLength, -$endLength) ) . 
	$TagsLastReplace{lc($tag)}->{-end};
    !gex;

    return ($string);
}    # PostFilterLastReplace

# ------------------------------------------------------------
sub HighlightPerlCode {
    my $code = shift;

    use Perl::Tidy;
    my @dest;
    perltidy(
        source      => \$code,
        destination => \@dest,

        #	      argv => '-html',
    );

    return join ( "", @dest );

}    # HighlightPerlCode

# ------------------------------------------------------------

Hallo Leute,

[b]das[/b] ist [i]mein [b]erstes[/i] Posting:
[perldoc]CGI[/perldoc] oder so.
[perle]#! /usr/bin/perl
use warnings;
use strict;
use CGI ();
my $cgi = CGI->new();[/perle]
und das[/b] ist was anderes:
[perldoc]CGI[/perldoc]
[perle]#! /usr/bin/perl
use warnings;
use strict;
use CGI ();
my $cgi = CGI->new();
my $string = "[perldoc]CGI[/perldoc]";[/perle]
normaltext
[quote]error
error
[quote]Strat, 12.08.2003 14:04
[URL=ftp://ftp.gnu.org/]ftp://ftp.gnu.org/[/URL] ftp.gnu.org
Quoting Level 1
[quote]
Quoting Level 2
[perle]#! /usr/bin/perl
@list = (1..30);
foreach (0..$#list) {
    print "$list[$_]";
}[/perle]
[URL=http://www.fabiani.net/]http://www.fabiani.net/[/URL]
[/quote]
Quoting Level 1 www.fabiani.net
[/quote]

s~\[quote\]~<;!--QuoteBegin-->;<table border="0" align="center" width="95%" cellpadding="0" cellspacing="0"><tr><td><b>Zitat</b> </td></tr><tr><td id="QUOTE"><;!--QuoteEBegin-->;~g;
s~\[/quote\]~<;!--QuoteEnd-->;</td></tr></table><;!--QuoteEEnd-->;~g;

#!/usr/bin/perl

use warnings;
use strict;
use Benchmark;

my $string = 'Soweit, Sogut ich blicke zwar durch Strats geschreibsel noch nicht ganz durch, aber es hat schon einen Haken: 

Module. Das ganze sollte ohne Module von Statten gehen.
Ich dachte das würde durch einen einfachen Ausdruck ala "s~/findedasundauchverschachtelt/erstzedann/g" funzen 
Bei der Quotingfunktion könnt ich mich noch auf nen Kompromiss einlassen und einfach 2 mal suchen/ersezten lassen (einmal

# viel text, viel text, viel Text

öffnenden Tag, einmal schliessenden). Dürfte allerdings, bei langen Postings, doch etwas lahmarschig sein.';

Benchmark::cmpthese(5000000, {
	'mit *' 	=> sub { $string =~ m/Ich.*funzen/g; },
        'ohne *' 	=> sub { $string =~ m/Ich/g; $string =~ m/funzen/g; },
});

C:\>ben.pl
           Rate  mit * ohne *
mit *  639959/s     --   -26%
ohne * 865052/s    35%     --