# -*- cperl -*-
# -----------------------------------------------------------------------------
# $Id: HTML.pm,v 1.4 2005/07/27 17:05:35 admin Exp $
# -----------------------------------------------------------------------------
package LinkExtractor::HTML;
use strict;
use warnings;
use HTML::Parser;
use HTML::Tagset;
use URI;
use LinkExtractor::CSS;

#$/ = undef;
#use Data::Dumper; print Dumper(extract(<>));

sub extract {
    # 戻り値: [[offset, tagname, link], [offset, tagname, link], ...]
    #    又は [[offset, tagname, link, base-url], ...]
    my $html_source = shift;

    my $base_url;
    my $result = [];
    my $in_style;
    my $_start_tag = sub {
	my ($self, $tagname, $attr, $offset) = @_;

	if (my $style = $attr->{style}) {
	    my $pos_content = index $html_source, $style, $offset;
	    my $urls = LinkExtractor::CSS::extract($style);
	    if (@$urls) {
		foreach my $url (@$urls) {
		    $url->[0] += $pos_content; # オフセット修正
		}
		push @$result, @$urls;
	    }
	}
	
	if ($tagname eq 'base') {
	    # baseタグは特別に扱ふ
	    $base_url = $attr->{href};
	}
	elsif ($tagname eq 'form') {
	    # form.actionは無視
	}
	elsif ($tagname eq 'link' and lc($attr->{rel} || '') ne 'stylesheet') {
		# rel="stylesheet" でない link は無視
	}
	elsif ($tagname eq 'style') {
	    $in_style = 1;
	}
	elsif (grep {$tagname eq $_} keys %HTML::Tagset::linkElements) {
	    my $links = $HTML::Tagset::linkElements{$tagname};
	    $links = [$links] unless ref $links;

	    foreach my $attrname (@$links) {
		my $url = $attr->{$attrname}
		  or next;

		# embed.pluginspageは無視
		if ($tagname eq 'embed' and
		      $attrname eq 'pluginspage') {
		    next;
		}
		# *.citeも無視
		if ($attrname eq 'cite') {
		    next;
		}

		# 實際のオフセットはURLそのものでなければならない。
		# $offsetに續く屬性名をまず探し、それに續くURLを探す。
		my $url_pos;
		if ($self->xml_mode) {
		    my $attr_pos = index $html_source, qq{$attrname="}, $offset;
		    $url_pos = $attr_pos + length(qq{$attrname="});
		}
		else {
		    my $attr_pos = index lc($html_source), qq{$attrname=}, $offset;
		    $url_pos = $attr_pos + length(qq{$attrname=});

		    my $next_char = substr($html_source, $url_pos, 1);
		    if ($next_char eq "'" or $next_char eq '"') {
			$url_pos++;
		    }
		}

		if ($url_pos == -1) {
		    warn "Failed to search url [$url] in the html";
		    next;
		}

		push @$result, [
		    $url_pos,
		    $tagname,
		    $url,
		    $base_url ? ($base_url) : (),
		   ];
	    }
	}
    };

    my $_end_tag = sub {
	my ($self, $tagname, $attr, $offset) = @_;
	if ($tagname eq 'style') {
	    $in_style = undef;
	}
    };

    my $_text = sub {
	my ($self, $text, $offset) = @_;
	if ($in_style) {
	    my $urls = LinkExtractor::CSS::extract($text);
	    foreach my $url (@$urls) {
		$url->[0] += $offset; # オフセット修正
	    }
	    push @$result, @$urls;
	}
    };

    my $p = HTML::Parser->new(
	api_version => 3,
	start_h     => [$_start_tag, "self,tagname,attr,offset"],
	end_h       => [$_end_tag, "self,tagname"],
	text_h      => [$_text, "self,dtext,offset"],
	#report_tags => ['base', 'style', keys %HTML::Tagset::linkElements],
       );
    $p->attr_encoded(1);
    
    if ($html_source =~ m/^\s*<\?xml/) {
	$p->xml_mode(1);
    }
    
    $p->parse($html_source);

    return $result;
}

1;
