#/*
# *  Copyright 2007 hkrn <hikarin@users.sourceforge.jp>
# *
# *  Licensed under the Apache License, Version 2.0 (the "License");
# *  you may not use this file except in compliance with the License.
# *  You may obtain a copy of the License at
# *
# *      http://www.apache.org/licenses/LICENSE-2.0
# *
# *  Unless required by applicable law or agreed to in writing, software
# *  distributed under the License is distributed on an "AS IS" BASIS,
# *  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# *  See the License for the specific language governing permissions and
# *  limitations under the License.
# */
#
# $Id: HTMLTag.pm 610 2007-05-09 14:49:15Z hikarin $
#

package Img0ch::Plugin::BBS::HTMLTag;

use strict;
use Config::Tiny qw();

sub parse {
    my ($iApp) = @_;
    my $tf;

    local $SIG{__WARN__} = sub { };
    $tf = Img0ch::Plugin::BBS::_HTMLTag->new(
        log_rejects              => 1,
        verbose                  => 1,
        strip_comments           => 0,
        echo                     => 0,
        verbose                  => 1,
        xss_risky_attributes     => [],
        xss_permitted_protocols  => [],
        xss_allow_local_links    => 0,
        skip_mailto_entification => 1,
        on_start_document        => sub {
            my ( $self, $rawtext ) = @_;
            $self->{_tag_stack} = [];
            return;
        },
        on_open_tag => sub {
            my ( $self, $tag, $attributes, $sequence ) = @_;
            $$tag = lc $$tag;

            #            return unless $self->tag_ok($$tag);
            if ( !grep { $_ eq $$tag } qw(img br hr meta link) ) {
                push @{ $self->{_tag_stack} }, $$tag;
            }
            return;
        },
        on_close_tag => sub {
            my ( $self, $tag ) = @_;
            if ( !@{ $self->{_tag_stack} }
                && grep { $_ eq $$tag } @{ $self->{_tag_stack} } )
            {
                undef ${$tag};
                return;
            }
            my @unclosed;
            while ( my $lasttag = pop @{ $self->{_tag_stack} } ) {
                return join '',
                    map { $self->tag_ok($_) ? "</$_>" : "&lt;/$_&gt;" }
                    @unclosed
                    if $lasttag eq $$tag;
                push @unclosed, $lasttag;
            }
        },
        on_finish_document => sub {
            my ( $self, $cleantext ) = @_;
            return join '',
                map { $self->tag_ok($_) ? "</$_>" : "&lt;/$_&gt;" }
                reverse @{ $self->{_tag_stack} };
        },
    );

    my $iKernel = $iApp->kernel();
    my $iConfig = $iKernel->get_config();
    my $path    = join '/', $iConfig->get('SystemPath'),
        ( $iConfig->get('TagsRuleConfig') || 'HTML-tags-rule.ini' );

    $tf->clear_rules();
    if ( -r $path and !-z $path ) {
        my $allowed = {};
        my $denied  = {};
        my $config  = Config::Tiny->read($path)
            or $iKernel->throw_io_exception( Config::Tiny->errstr() );
        while ( my ( $tag, $attributes ) = each %$config ) {
            $tag eq '_' and $tag = 'any';
            $allowed->{$tag} ||= {};
            $denied->{$tag}  ||= {};
            while ( my ( $attribute, $allow_or_deny ) = each %$attributes ) {
                $allow_or_deny
                    ? $allowed->{$tag}->{$attribute}
                    = []
                    : $denied->{$tag}->{$attribute} = [];
            }
        }
        $tf->allow_tags($allowed);
        $tf->deny_tags($denied);
    }
    else {
        $tf->allow_tags(
            {   'b'    => { 'none' => [] },
                'font' => {
                    'color' => [],
                    'size'  => []
                },
                'i' => { 'none' => [] },
                's' => { 'none' => [] },
                'u' => { 'none' => [] },
            }
        );
    }
    $tf->deny_tags(
        {   'a'     => { 'all' => [] },
            'br'    => { 'all' => [] },
            'blink' => { 'all' => [] },
            'any'   => {
                'style'       => [],
                'onmouseover' => [],
                'onclick'     => [],
                'onmouseout'  => [],
            },
            'hr'      => { 'all' => [] },
            'marquee' => { 'all' => [] },
            'img'     => { 'all' => [] },
        }
    );

    my $text = $iApp->get_comment();
    $text =~ s|<br>|\n|gxms;
    $text =~ s|<hr>|\a|gxms;
    while ( $text =~ m|&lt;(/?([A-Za-z]+).*?)&gt;|gcxms ) {
        my ( $inner, $tag ) = ( $1, $2 );
        if ( $tf->tag_ok( lc $tag ) ) {
            my $replace = $inner;
            $replace =~ s/\A&lt;([A-Za-z])/&lt;\L$1\E/xms;
            $replace =~ s/(A-Za-z)=/\L$1\E=/gxms;
            $replace =~ s/&quot;/"/gxms;
            $text    =~ s|&lt;\Q${inner}\E&gt;|<${replace}>|xms;
        }
    }
    $text =~ s|</>||gxms;
    $text = $tf->filter($text);
    $text =~ s|\n|<br>|gxms;
    $text =~ s|\a|<hr>|gxms;
    $text =~ s|<!--|&lt;!--|gxms;    # FOR COMMENT IN NESTED TAG
    $iApp->set_comment($text);

    return 1;
}

package Img0ch::Plugin::BBS::_HTMLTag;

use strict;
use HTML::TagFilter qw();

@Img0ch::Plugin::BBS::_HTMLTag::ISA = qw(HTML::TagFilter);

sub filter_start {
    my ( $self, $tagname, $attributes, $attribute_sequence ) = @_;
    $self->_call_trigger( 'on_open_tag', \$tagname, $attributes,
        $attribute_sequence );
    return if !$tagname;

    my %quote_ok        = ();
    my $lowered_tagname = lc $tagname;
    for (@$attribute_sequence) {

        # (tag, attribute, value)
        my @data = ( $lowered_tagname, lc($_), lc( $attributes->{$_} ) );
        my $tag_ok = $self->tag_ok($lowered_tagname);
        my $attribute_ok = $self->attribute_ok(@data);

        # <br />を<br>に修正する
        delete $attributes->{$_} if m|^/$|;

# タグは許可しているが属性を許可していない場合はその属性のみを削除する
        if ( $tag_ok and !$attribute_ok ) {
            delete $attributes->{$_};
        }

# タグおよび属性を許可している場合は引用符(")の使用を許可する
        $quote_ok{ $data[0] } = 1 if $tag_ok and $attribute_ok;
    }

# タグを許可している場合は「"」で、そうでない場合は「&quot;」となる
    my $quote = $quote_ok{$lowered_tagname} ? '"' : '&quot;';
    my $surviving_attributes = join(
        '',
        map {
                  ' ' 
                . $_ . '=' 
                . $quote
                . $self->_xss_clean_attribute( $attributes->{$_}, $_ )
                . $quote
            } grep { defined $attributes->{$_} } @$attribute_sequence
    );
    $surviving_attributes =~ s/"+/"/g;
    $surviving_attributes =~ s/(?:&quot;)+/&quot;/g;

    if ( !$self->tag_ok($lowered_tagname) ) {
        $self->add_to_output("&lt;${tagname}${surviving_attributes}&gt;");
    }
    else {
        $self->add_to_output("<${tagname}${surviving_attributes}>");
    }
}

sub filter_end {
    my ( $self, $tagname ) = @_;
    $self->_call_trigger( 'on_close_tag', \$tagname );
    return if !$tagname;
    if ( $self->tag_ok( lc($tagname) ) ) {
        $self->add_to_output("</${tagname}>");
    }
    else {
        $self->add_to_output("&lt;/${tagname}&gt;");
    }
}

1;
__END__
