#/*
# *  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: AutoLink.pm 709 2007-05-27 14:00:11Z hikarin $
#

package Img0ch::Plugin::Rewrite::AutoLink;

use strict;
use Img0ch::Setting qw();

sub new {
    my ( $iClass, $iBBS ) = @_;
    my $iConfig = $iBBS->get_kernel()->get_config();
    my $use_idn = 0;
    if ( $iConfig->get('EnableIDN') ) {
        eval { require Net::LibIDN; 1 } and $use_idn = 1;
    }

    my $mb_space = pack 'C*', ( 0x81, 0x40 );
    $mb_space = qr/$mb_space/xms;
    my $url_re = qr{
        (?<!")
        (ftp|https?)://
        ([A-Za-z0-9\-\.]+/?)
        ([-_.!~*'()a-zA-Z0-9;/?:\@\&=+\$,%#]*)/?
    }xms;
    my $idn_re = qr{
        (?<!")
        (ftp|https?)://
        ([A-Za-z0-9\-\.]+/?|[^/<>_!~*'();/?\@\&=+\$,\%#]+[A-Za-z]+/?)
        ([-_.!~*'()a-zA-Z0-9;/?:\@\&=+\$,\%#]*)
    }xms;
    my $cushion          = Img0ch::Setting->new($iBBS)->get('BBS_CUSHION');
    my $server           = $iConfig->get('Server');
    my $autolink_closure = sub {
        my ( $text, $mobile ) = @_;
        my $re = $use_idn ? $idn_re : $url_re;
        $server =~ /$re/xms;
        my $svr = qr/$2/xms;

        $$text =~ s{$re}{
            my ($s, $c, $m) = ($svr, $cushion, $mobile);
            my ($p, $d, $u) = ($1, $2, $3);
            my $idn = $use_idn
                ? Net::LibIDN::idn_to_ascii($d, 'shift_jis')
                : $d;
            if ($c and !$m) {
                my $url = $idn . $u;
                return $url =~ /$s/ ?
                    "<a href=\"${p}://${url}\">${p}://${d}${u}</a>"
                    : "<a href=\"${p}://${c}${url}\" "
                      . "rel=\"nofollow\">${p}://${d}${u}</a>";
            }
            $mobile and $d =~ s|/\z||xms;
            my $inner = $m ? $d : "${p}://${d}${u}";
            "<a href=\"${p}://${idn}${u}\" rel=\"nofollow\">${inner}</a>";
        }gxmse;
    };

    bless [$autolink_closure], $iClass;
}

sub from_bbs {
    my ( $iObject, $key, $count, $resno, $text ) = @_;
    $iObject->[0]->( $text, 0 );
    return;
}

*from_read = \&from_bbs;

sub from_mobile {
    my ( $iObject, $key, $count, $resno, $text, $param ) = @_;
    $iObject->[0]->( $text, 1 );
    return;
}

1;
__END__
