#! perl
#
# wrtten by Yuichi Koike ($Id: step2.pl,v 1.1 2000/10/05 21:31:06 koike Exp $)
#
# Modules
use strict;
require "mylib.pl";

package P3P::HTMLCheck;

sub new {
	my($class, $fn) = @_;
	bless {pr => 0}, $class;
}

sub uri {
	my ($self) = @_;

	return $self->{pr_uri};
}

sub check {
	my ($self, $uri, $step1, $puri, $pr, $step) = @_;
	$self->{pr} = $pr;
	$self->{content} = $step1->content;
	$self->{content_type} = $step1->content_type;
	$self->{http_uri} = $step1->uri;
	$self->{step} = $step;
	$self->{puri} = $puri;
	$self->{uri} = $uri;

	$self->init;
	my @result = $self->html_result;
}

sub init {
	my ($self) = @_;
	my $pr = $self->{pr};
	my $step = $self->{step};

	# HTML header checking
	$pr->pri("<hr>");
	$pr->pri("<p><span class='step'>Step $step: </span>\n");
	$pr->pri("<span class='big'>HTML Header Validation</span></p>\n");
}

sub html_result {
	my ($self) = @_;
	my $pr = $self->{pr};
	my $http_uri = $self->{http_uri};
	my $result3 = $self->html_check;
	my $pr_uri = $self->{pr_uri};

	my $puri = $self->{puri};
	my $wellknown;
	if($puri) {
		$wellknown = $self->{uri};
		$wellknown =~ s/(http:\/\/.*?)\/.*/$1\/p3p.xml/;
	}

	my $tmp_res = $result3;
	if($result3 eq 0) {
		if($puri eq "" && $http_uri eq "") {
			$pr->pri("<p class='result'>HTML headers are \n");
			$pr->pri("<font color='red'>NOT P3P compatible</font>.</span><p>\n");
		} else {
			$pr->pri("<p class='result'>HTML headers have \n");
			$pr->pri("no P3P compatible elements.</span><p>\n");
		}
	} else {
		if($puri) {
			if($wellknown ne $pr_uri) {
				$tmp_res = 2;
				$pr->err("HTML headers indicates different policy reference file URI than <tt>/p3p.xml</tt> file.\n");
			}
		} elsif($http_uri ne "" && $http_uri ne $pr_uri) {
			$tmp_res = 2;
			$pr->err("HTML headers indicates different policy reference file URI than HTTP headers.\n");
			$pr->mes("[<tt>$http_uri</tt>] \nwill be used for the following validation.\n");
		}

		if($tmp_res eq 1) {
			$pr->pri("<p class='result'>HTML headers are \n");
			$pr->pri("<font color='blue'>P3P compatible</font>.</span><p>\n");
		} else {
			$pr->pri("<p class='result'>HTML headers are \n");
			$pr->pri("<font color='green'>P3P compatible</font>, \n");
			$pr->pri("but some errors.</span><p>\n");
		}
	}
	$pr->print_all;
}

sub html_check {
	my ($self) = @_;
	my $pr = $self->{pr};
	my $content = $self->{content};
	my $content_type = $self->{content_type};

	my $in_head = $content;
	my $retu = 0;

	# is HTML?
	if($content_type ne "text/html") {
		# Not HTML
		my $str = "This is not an HTML page. \n";
		$str = $str."Content type is <b>$content_type</b>. \n";
		$pr->mes($str."Checking skipped.");
		return $retu;
	}

	# extract <head>.....</head>
	if(! ($in_head =~ s/.*?<head.*?>(.*?)<\/head>.*/\1/is)) {
		# No good header
		$pr->mes("No valid HTML <tt>&lt;head&gt;</tt> element.");
		return $retu;
	}

	# extract links
	my @links;
	while($in_head =~ s/(<link\s+.*?>)//is) {
		my $link = $1;
		if($link =~ /<link\s+.*?rel\s*=\s*(?:\"|\')P3Pv1(?:\"|\')\s+.*?>/i) {
			push(@links, $link);
		}
	}

	# print links
	my $str = "";
	foreach my $link (@links) {
		$str = $str.$link."\n";
	}
	$str =~ s/</&lt;/gsi;
	$str =~ s/>/&gt;/gsi;
	$pr->code($str);

	my @retu;
	if($#links eq -1) {
		# no P3P <link>
		$pr->mes("No P3P <tt>&lt;link&gt;</tt> element.");
		return @retu;
	} elsif($#links > 0) {
		# too many P3P <link>
		$pr->warn("More than one P3P <tt>&lt;link&gt;</tt> elements.");
	}

	# extract href="URL"
	my $link_warn = 0;
	my %urldic;
	foreach my $out_link (@links) {
		if($out_link =~ /(<link\s+(.*?)rel\s*=\s*(?:\"|\')P3Pv1(?:\"|\')\s+(.*?)>)/is) {
			my $in_link = " ".$1.$2." ";
			my $count = 0;
			while($in_link =~ s/\s+.*?href\s*=\s*(?:\"|\')(.*?)(?:\"|\')//is) {
				$count++;
				$urldic{$1} = "ok";
			}
			if($count > 1) {
				$link_warn = 1;
			}
		}
	}

	# how many urls?
	my @urls = keys(%urldic);
	if($#urls eq -1 || $#urls > 0) {
		if($#urls eq -1) {
			$pr->err("Invalid P3P &lt;link&gt; elements.");
		} else {
			$pr->err("Multiple policy reference file URI candidates.");
		}
		return $retu;
	} else {
		if($#links ne 0) {
			$retu = 2;
		} else {
			$retu = 1;
		}
		my $result_uri = $urls[0];
		unless($result_uri =~ /^http/ ) {
			my $base_uri = $self->{uri};
			if($result_uri =~ /^\//) {
				$base_uri =~ /(http:\/\/.*?)\//;
				$result_uri = $1.$result_uri;
			} else {
				$base_uri =~ /(.*\/)/;
				$result_uri = $1.$result_uri;
			}
		}

		$self->{pr_uri} = $result_uri;
		return $retu;
	}
}
