# -------------------------------------------------------------------------------------
# flo::XHTMLFilter
# -------------------------------------------------------------------------------------
#
#       Author : Jean-Michel Hiver (jhiver@cisedi.com).
#    Copyright : (c) MKDoc Holdings Ltd, 2001
# 
#      Unauthorized modification, use, reuse, distribution or redistribution
#      of this module is stricly forbidden
#
#    Description:
#
#      flo::XHTMLFilter is a module based on a heavy use of regular expressions
#      that uses Robert D. Cameron XML shallow parsing in order to achieve two tasks:
#      cleaning up XHTML content, and linkifing it
#
# -------------------------------------------------------------------------------------
package flo::XHTMLFilter;
use lib::util::Text2Html;
use lib::Config;
use strict;
use vars qw /$STOP_TAGS $DONT_STRIP $XML_SPE/;

# warning: the STOP-TAG 'a' is mandatory !!!
$STOP_TAGS  = { map { $_ => 1 } qw /a select option textarea summary/ };
$DONT_STRIP = undef;


##
# Found on http://www.cs.sfu.ca/~cameron/REX.html
# -----------------------------------------------
#   REX/Perl 1.0
#   Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions",
#   Technical Report TR 1998-17, School of Computing Science, Simon Fraser
#   University, November, 1998.
#   Copyright (c) 1998, Robert D. Cameron.
#   The following code may be freely used and distributed provided that
#   this copyright and citation notice remains intact and that modifications
#   or additions are clearly identified
##
my $TextSE = "[^<]+";
my $UntilHyphen = "[^-]*-";
my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-";
my $CommentCE = "$Until2Hyphens>?";
my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>";
my $S = "[ \\n\\t\\r]+";
my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
my $Name = "(?:$NameStrt)(?:$NameChar)*";
my $QuoteSE = "\"[^\"]*\"|'[^']*'";
my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*";
my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>";
my $S1 = "[\\n\\r\\t ]";
my $UntilQMs = "[^?]*\\?+";
my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>";
my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S";
my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?";
my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";
my $PI_CE = "$Name(?:$PI_Tail)?";
my $EndTagCE = "$Name(?:$S)?>?";
my $AttValSE = "\"[^<\"]*\"|'[^<']*'";
my $ElemTagCE = "$Name(?:$S$Name(?:$S)?=(?:$S)?(?:$AttValSE))*(?:$S)?/?>?";
my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)";
$XML_SPE = "$TextSE|$MarkupSPE";


sub init
{
    my $cfg = new lib::Config ('flo.XHTMLFilter');
    $DONT_STRIP = { map { $_ => 1 } $cfg->keys };
}


##
# $class->purify ($xhml);
# -----------------------
#   Remove undesirable, horrible tags from $xhtml, just to meanly prevent Chris from
#   using inline CSS and Florian from incorporating javascript into MKDoc documents.
#   Programmer's life is hard... but hey, you're the man
##
sub purify
{
    my $class = shift;
    my $data  = shift;
    my @links = @_;
    
    # turns the data into a list of tokens
    my @tokens = _tokenize ($data);
    
    my @res = ();
    while (@tokens)
    {
        my $token = shift (@tokens);
        if (ref $token)
        {
            my $token_name = $token->{start};
	    $token_name = $token->{stop} unless (defined $token_name);
            next unless (defined $DONT_STRIP->{$token_name});
	    
	    push @res, $token->{raw};	    
	}
	else
	{
	    push @res, $token;	    
	}
    }

    return join '', @res;
}


##
# linkify ( $xhtml,
#         { href => 'www.yahoo.fr',  desc => 'my title', expr => 'my expression' }
#         { href => 'www.yahoo2.fr', desc => 'my cool title', expr => 'my other expression' }
#         { href => 'www.yahoo3.fr', desc => 'my wonderful title', expr => 'yet another expression' } );
# ------------------------------------------------------------------------------------------------------
#   Adds links to $xhtml and returns the linkified string
##
sub linkify
{
    my $class = shift;
    my $data  = shift;
    my @links = @_;
    
    # we don't want the data to have wierd spaces, let's kill'em all!
    $data =~ s/\&nbsp\;//gsim;
    $data =~ s/\&\#32\;//gsim;
    $data =~ s/\&sp\;//gsim;
    
    # build the regexes coderefs that will be used to match contents
    $class->_build_regexes (@links);
    
    # $balance is used for when we're inside tags in which we're not supposed
    # to hyperlink anything, such as <option>...</option>
    my $balance = 0;
    
    # turns the data into a list of tokens
    my @tokens = _tokenize ($data);
    
    my @res = ();
    while (@tokens)
    {
        my $token = shift (@tokens);
	
	# if $token is a reference, then it represents an HTML tag and
	# thus we should check that we can process it
        if (ref $token)
        {
            my $token_name = $token->{start};
	    $token_name = $token->{stop} unless (defined $token_name);
	    push @res, $token->{raw};
            
            # if we could not determine which kind of tag it is,
            # let's pretend it's ok
            next unless (defined $token_name);
            
            # if the tag is not in the $STOP_TAGS, then there is no
            # problem
            next unless (defined $STOP_TAGS->{$token_name});
            
            # if the tag is closing as well as opening, then there is
            # no problem
            next if ($token->{start} and $token->{stop});
	    
            # otherwise, the tag is in the stop list, and it's either
            # a start or stop tag
            if    (defined $token->{start}) { $balance++ }
            elsif (defined $token->{stop})  { $balance-- }
        }

	# if $token is not a reference, then it's a bit of text that we
	# may want to linkify
        else
	{
	    # we can perform only if $balance == 0, which means that we
	    # we are not processing text which would be into a mean tag
            if ($balance == 0)
            {
		# for the moment, @tokens is quite small but it'll eventually
		# grow because when an expression matches, it creates a link
		# i.e. 3 more tokens
		
		# WARNING! @tokens does not represent ALL the tokens anymore
		# we want to HTML decode $token to text because we know it's got
		# no XHTML tags, but only HTML entities which we do not want as
		# they make matching regexes harder to build and slower
		my @tokens = $token;
		foreach my $link (@links)
		{
		    # NOTE: This piece of code was previously a subroutine,
		    # it has been inlined for performance (thank you -d:DProf)
		    my $i = 0;
		    while ($i < @tokens)
		    {
			my $token = $tokens[$i];
			
			# if the token is a reference, then it HAS to be an 'a' tag,
			# thus we should jump two tokens further
			if (ref $token)
			{
			    if (defined $token->{start}) { $i += 2 }
			    else                         { $i++    }
			}
			else
			{
			    $token = html2text ($token);
			    my $re_split = $link->{re_split};
			    
			    # first of all, let's split the token
			    if ($token !~ /$re_split/ism)
			    {
				$i++;
				next;
			    }
			    
			    my ($first, $third) = split /$re_split/ism, $token, 2;
			    my ($second) = $token =~ /($re_split)/ism;

			    # html reencode $first and $second
			    $first  = text2html ($first);
			    $third  = text2html ($third);
			    
			    # the $second token contains the expression that needs being encoded
			    # now we need to capture that expression in order to build the hyperlink
			    my $re_capture = $link->{re_capture};
			    my ($expression) = $second =~ /$re_capture/ism;
			    my $replace = $link->{a_start} . text2html ($expression) . '</a>';
			    my $q_expression = quotemeta ($expression);
			    $second =~ s/$q_expression/$replace/ism;
			    
			    splice @tokens, $i, 1, _tokenize ($first . $second . $third);
			    $i += 3;
			}
		    }
		    # END of inlined subroutine
		}
		
		# now that we've linkified that bit, let's push it
		# to the result array. Don't forget to HTML re-encode
		# the text which was previously decoded
		push @res, map { (ref $_) ? $_->{raw} : ($_) } @tokens;
            }
            else
            {
                push @res, $token;
            }
        }
    }

    # looks like we've got it all, let's return the linkified data
    return join '', @res;
}


##
# $class->_build_regexes (@links);
# --------------------------------
#   For each link, we need to compute a regular expression that will match
#   the html encoded expression
##
sub _build_regexes
{
    my $class = shift;
    my @links = @_;
    foreach my $link (@links)
    {
	# maybe that link was already processed, in which case
	# we don't want to redo the same work again and again
	next if (defined $link->{linkify});
	
	my $expr = $link->{expr};
	my @expr = split /(?:\s|\n|\r)/gism, $expr;
	my $re = join '(?:\s|\n|\r|\&nbsp\;)+', map { quotemeta ($_) } @expr;
	
	my $word_re = '[A-Za-z0-9\xC0-\xD6\xD8-\xDF\xE0-\xF6\xF8-\xFF]';
	
	# when it matches, this regular expression will return three elements:
	# my ($before, $expr, $after) = $data =~ /$re/
	my $re_split = "(?<!$word_re)" . $re . "(?!$word_re)";
	my $re_capture = "(?<!$word_re)(" . $re . ")(?!$word_re)";
	$link->{re_split} = $re_split;
	$link->{re_capture} = $re_capture;
	
	my $href = $link->{href};
	my $lang = $link->{lang};
	my $desc = text2html ($link->{desc});
	if (defined $lang and $lang ne '' and defined $desc and $desc ne '')
	{
	    $link->{a_start} = "<a href=\"$href\" hreflang=\"$lang\" title=\"$desc\">";
	}
	elsif (defined $lang and $lang ne '')
        {
	    $link->{a_start} = "<a href=\"$href\" hreflang=\"$lang\">";
        }
	elsif (defined $desc and $desc ne '')
	{
	    $link->{a_start} = "<a href=\"$href\" title=\"$desc\">";
	}
	else
	{
	    $link->{a_start} = "<a href=\"$href\">";
	}
    }
}


##
# _tokenize;
# ----------
#   Splits the XML $data into tokens which are easy to process.
#   A token can either be a hash reference (representing a tag)
#   or some text
##
sub _tokenize
{
    my $data = shift;
    
    my @tokens = _xml_parse ($data);
    my @res = ();
    foreach my $token (@tokens)
    {
	if (index ($token, '<') == 0)
        {
            my $start = 0;
            my $stop  = 0;
	    if (index ($token, '</') == 0) { $stop  = 1 }
            else                           { $start = 1 }
            $stop = 1 if (index ($token, '/>') > 0);
            
	    my ($token_name) = $token =~ /.*?([A-Za-z0-9]+)/;
            my %hash = $token =~ /((?:\w|:)+)=\"(.*?)\"/gsim;
            
            $hash{'start'} = $token_name if ($start);
            $hash{'stop'}  = $token_name if ($stop);
            $hash{'raw'}   = $token;
            
            push @res, \%hash;
        }
        else
        {
            push @res, $token;
        }
    }
    
    return @res;
}


##
# _xml_parse;
# -----------
#   Splits the XML $data into tokens which are easily processable
##
sub _xml_parse
{
    # taken from Robert D. Cameron ShallowParse() subroutine
    # $XML_SPE does not need to be compiled more than once, thus I added a 'o' modifier
    # Jean-Michel Hiver, 2001-06-24
    my ($XML_document) = shift;
    return $XML_document =~ /$XML_SPE/go;
}


1;

