#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃■C-BOARD Moyukuライブラリ
#┠──────────────────────────────────────
#┃ＨＴＭＬに関する関数が含まれています。
#┃
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

package HTML;

#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   オートローダー
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
sub AUTOLOAD {
    my $name = ($AUTOLOAD =~ /^HTML::(.+)$/)[0];
    push(@{$::FLAG{'eval'}}, $AUTOLOAD);
    if (!defined $SUB{$name}) {
        &::error(\"定義されていない関数($AUTOLOAD)が呼ばれました。"); exit;
    }
    eval $SUB{$name}; length($@) && &::error(\"EVAL ERROR: $@ ($AUTOLOAD)");
    delete $SUB{$name}; goto &{'HTML::' . $name};
}

%SUB = (
    escape => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   ＨＴＭＬエスケープ
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub escape {
        local *str = shift;
        $str =~ s/&(?!(?:amp|quot|lt|gt);)/&amp;/g; $str =~ s/"/&quot;/g;
        $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g; return(\$str);
    }
__SUB__

    unescape => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   ＨＴＭＬアンエスケープ
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub unescape {
        local *str = shift;
        $str =~ s/&quot;/"/g; $str =~ s/&lt;/</g; $str =~ s/&gt;/>/g;
        $str =~ s/&amp;/&/g; return(\$str);
    }
__SUB__

    auto_link => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   オートリンク
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub auto_link {
        local *str = shift; my $target = shift;

		#すでにリンクなどを含んでいる場合は作動を回避（書き込み保全重視）
		if ( ( $str =~ /href=/i ) || ( $str =~ /src=/i ) ) {
			return;
		}


##Moyuku メールのオートリンクは行わない（実用性としても重要度は低い）
#	$mail_regex =
#		q{(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\} .
#		q{\[\]\000-\037\x80-\xff])|"[^\\\\\x80-\xff\n\015"]*(?:\\\\[^\x80-\xff][} .
#		q{^\\\\\x80-\xff\n\015"]*)*")(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x} .
#		q{80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff])|"[^\\\\\x80-} .
#		q{\xff\n\015"]*(?:\\\\[^\x80-\xff][^\\\\\x80-\xff\n\015"]*)*"))*@(?:[^(} .
#		q{\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\0} .
#		q{00-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[^\x80-\xff])*} .
#		q{\])(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,} .
#		q{;:".\\\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[} .
#		q{^\x80-\xff])*\]))*};

#		#&STRING::sjis2euc(\$str);
#		$str =~ s/((?:https?|ftp):\/\/[\w-]+\.[\w-.:]+
##とほほ修正オリジナル→(?:\/[^\s()\[\]{}!"'<>:,\x7f-\xff]*)?)
#                  (?:\/[^\s\[\]{}!"<>\x7f-\xff]*)?)
#                 /&auto_link_sub($1)/egox;
#		#$str =~ s/($mail_regex)/<a href="mailto:$1">$1<\/a>/gox;
#		#&STRING::etc2sjis(\$str);


		#"http:// など頭にダブルクォートもまとめて処理
		$str =~ s/((?:"?https?|"?ftp):\/\/[\w-]+\.[\w-.:]+(?:\/[^\s\[\]{}!"<>\x7f-\xff]*)?)
					/&auto_link_sub($1)/egox;

        return(\$str);

        sub auto_link_sub {
            my $url = shift;
            if ( $url =~ /^https?|^ftp/ ) {		#ダブルクォートよけ
				$url=~ /^(.*?)(&(?:quot|lt|gt);.*)?$/;
                return(qq|<a href="$1" target="$target">$1<\/a>$2|);
            } else { 
            	return($url);
            }
        }

    }
__SUB__

    auto_unlink => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   オートリンク解除
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub auto_unlink {
        my $r_str = shift;
        ${$r_str} =~ s/<a href="(?:mailto:)?([^"]+)"[^>]*>\1<\/a>/$1/g;
        return($r_str);
    }
__SUB__

    check => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   許可されていないタグをエスケープ＆閉じ忘れ防止
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub check {
        local *str = shift; local *enable = shift; my $java = shift;
        my $style = shift; my $target = shift; my $mode = shift;
        my @str = split(/(<[^>]*>)/, $str); $str = shift(@str);
        &auto_link(&escape(\$str), $target, $mode); my @tag;
        while (@str) {
            my($tag, $text) = splice(@str, 0, 2); &escape(\$text);
            my $tag_tmp = $tag; $tag_tmp =~ s/\n//g;
            if ($tag_tmp =~ /^<(\w+)(\s+[^>]+)?>/) {
                my $name = lc($1); my $property = $2;
                if (!exists $enable{$name}) { &escape(\$tag);}
                else {
                    $enable{$name} && push(@tag, $name); my $property_tmp;
                    while ($property =~ /\s+([^=]+)(=(?:"([^"]*)"|'([^']*)'
                                         |([^"' ]+)))?/gx) {
                        if (length($2)) {
                            my $name = $1;
                            my $value = length($3) ? $3 : (length($4) ? $4
                                      : (length($5) ? $5 : ''));
                            if ($name =~ /^(on|javascript:)/i && !$java) {
                                next;
                            }
                            elsif ($name =~ /^style/i && !$style) { next;}
                            &escape(\$value);
                            $property_tmp .= qq| $name="$value"|;
                        }
                        else {
                            my $value = $1; &escape(\$value);
                            $property_tmp .= qq| $value|;
                        }
                    }
                    $tag = "<$name$property_tmp>";
                }
            }
            elsif ($tag =~ /^<\/(\w+)>/) {
                my $name = lc($1);
                if (grep($_ eq $name, @tag)) {
                    $tag = '';
                    while (@tag) {
                        my $name_tmp = pop(@tag); $tag .= "</$name_tmp>";
                        ($name eq $name_tmp) && last;
                    }
                }
                else { &escape(\$tag);}

            }
            else { &escape(\$tag);}
            grep($_ eq 'a', @tag) or &auto_link(\$text, $target, $mode);
            $str .= "$tag$text";
        }
        @tag && ($str .= '</' . join('></', @tag) . '>'); return(\$str);
    }
__SUB__

    check_url => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   ＵＲＬの存在チェック
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub check_url {
        my $url = shift;

        #── Ｓｏｃｋｅｔモジュールをロード
        eval('use Socket'); length($@) && return(1);

        #── 前準備
        my($host, $path) = split(/\//, ($url =~ /^http:\/\/(.*)$/)[0], 2);
        $path = '/' . $path;
        ($path ne '/' && ($path =~ /([^\/]+)$/)[0] !~ /\./) && ($path .= '/');
        my $iaddr;
        if($host =~ /^(\d{1, 3})\.(\d{1, 3})\.(\d{1, 3})\.(\d{1, 3})$/) {
            $iaddr = pack('C4', $1, $2, $3, $4);
        }
        else { ($iaddr = inet_aton($host)) or return(1);}

        #── ソケットを作成して接続
        socket(HTTP, PF_INET, SOCK_STREAM, getprotobyname('tcp')) or return(1);
        if (!connect(HTTP, pack_sockaddr_in(getservbyname('http', 'tcp') || 80,
                     $iaddr))) {
            close(HTTP); return(1);
        }

        #── バッファリングオフ
        select((select(HTTP), $| = 1)[0]);

        #── リクエスト
        send(HTTP, "GET $path HTTP/1.1\r\nHost: $host\r\n"
                 . "User-Agent: $::SYS{'name'}/$::SYS{'version'}\r\n\r\n", 0) or return(1);

        #── レスポンスを受信
        my $receive;
        recv(HTTP, $receive, 64, 0) or return(1); close(HTTP);

        #── ステータスをチェック
        return(($receive =~ /^HTTP\/1\.[01] 2\d{2}/) ? 1 : 0);
    }
__SUB__

    name2hex => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   色名⇔８進数変換
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub name2hex {
        my $name = shift;
        defined $TABLE{'name2hex'} or &name2hex_table;
        return($TABLE{'name2hex'}{$name} ? '#' . $TABLE{'name2hex'}{$name}
                                         : '');
    }
__SUB__

    name2hex_table => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   色名⇔８進数変換用テーブル
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub name2hex_table {
        my %table = qw(
        black 000000 navy 000080 darkblue 00008b mediumblue 0000cd blue 0000ff
        darkgreen 006400 green 008000 teal 008080 darkcyan 008b8b deepskyblue
        00bfff darkturquoise 00ced1 mediumspringgreen 00fa9a lime 00ff00
        springgreen 00ff7f aqua 00ffff cyan 00ffff midnightblue 191970
        dodgerblue 1e90ff lightseagreen 20b2aa forestgreen 228b22 seagreen
        2e8b57 darkslategray 2f4f4f limegreen 32cd32 mediumseagreen 3cb371
        turquoise 40e0d0 royalblue 4169e1 steelblue 4682b4 darkslateblue 483d8b
        mediumturquoise 48d1cc indigo 4b0082 darkolivegreen 556b2f cadetblue
        5f9ea0 cornflowerblue 6495ed mediumaquamarine 66cdaa dimgray 696969
        slateblue 6a5acd olivedrab 6b8e23 slategray 708090 lightslategray
        778899 mediumslateblue 7b68ee lawngreen 7cfc00 chartreuse 7fff00
        aquamarine 7fffd4 maroon 800000 purple 800080 olive 808000 gray 808080
        skyblue 87ceeb lightskyblue 87cefa blueviolet 8a2be2 darkred 8b0000
        darkmagenta 8b008b saddlebrown 8b4513 darkseagreen 8fbc8f lightgreen
        90ee90 mediumpurple 9370db darkviolet 9400d3 palegreen 98fb98
        darkorchid 9932cc yellowgreen 9acd32 sienna a0522d brown a52a2a
        darkgray a9a9a9 lightblue add8e6 greenyellow adff2f paleturquoise
        afeeee lightsteelblue b0c4de powderblue b0e0e6 firebrick b22222
        darkgoldenrod b8860b mediumorchid ba55d3 rosybrown bc8f8f darkkhaki
        bdb76b silver c0c0c0 mediumvioletred c71585 indianred cd5c5c peru
        cd853f chocolate d2691e tan d2b48c lightgrey d3d3d3 thistle d8bfd8
        orchid da70d6 goldenrod daa520 palevioletred db7093 crimson dc143c
        gainsboro dcdcdc plum dda0dd burlywood deb887 lightcyan e0ffff lavender
        e6e6fa darksalmon e9967a violet ee82ee palegoldenrod eee8aa lightcoral
        f08080 khaki f0e68c aliceblue f0f8ff honeydew f0fff0 azure f0ffff
        sandybrown f4a460 wheat f5deb3 beige f5f5dc whitesmoke f5f5f5 mintcream
        f5fffa ghostwhite f8f8ff salmon fa8072 antiquewhite faebd7 linen faf0e6
        lightgoldenrodyellow fafad2 oldlace fdf5e6 red ff0000 fuchsia ff00ff
        magenta ff00ff deeppink ff1493 orangered ff4500 tomato ff6347 hotpink
        ff69b4 coral ff7f50 darkorange ff8c00 lightsalmon ffa07a orange ffa500
        lightpink ffb6c1 pink ffc0cb gold ffd700 peachpuff ffdab9 navajowhite
        ffdead moccasin ffe4b5 bisque ffe4c4 mistyrose ffe4e1 blanchedalmond
        ffebcd papayawhip ffefd5 lavenderblush fff0f5 seashell fff5ee cornsilk
        fff8dc lemonchiffon fffacd floralwhite fffaf0 snow fffafa yellow ffff00
        lightyellow ffffe0 ivory fffff0 white ffffff
        );
        return($TABLE{'name2hex'} = \%table);
    }
__SUB__

    undef_table => <<'__SUB__',
#┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
#┃   変換用テーブルを破棄
#┗━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
    sub undef_table {
        undef $TABLE{'name2hex'};
    }
__SUB__
);

1;