######################################################################
#
# Perl module: P3P::PolicyCheck
#
######################################################################
#
# $Id: policycheck.pl,v 1.11 2001/10/10 13:35:02 koike Exp $
# Created by Yuichi Koike (koike@w3.org)
#

use strict;
my $Namespace = 10;
my $Line      = 11;

######################################################################
package P3P::PolicyCheck;
######################################################################

sub new {
	my ($class, %args) = @_;
	my $self = bless {}, $class;
	my @errors;
	$self->{errors} = \@errors;
	return $self;
}

sub uri {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{uri} = $arg;
	} else {
		return $self->{uri};
	}
}

sub prf_uri {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{prf_uri} = $arg;
	} else {
		return $self->{prf_uri};
	}
}

sub check {
	my ($self, $step, $pr) = @_;
	$self->{step} = $step;
	$self->{pr} = $pr;
	my $uri = $self->{uri};

	# Initial Message
	$pr->pri("<hr>\n");
	$pr->step($step, 0, "Policy File Validation");
	$pr->pri("<p><span class='result'>URI:</span> 
<a target='policy' href='header.pl?mode=line&uri=$uri'><tt>$uri</tt></a></p>\n");


	# Syntax Check
	if(! $self->syntax) {
		return 0;
	}

	# Vocaburaly check
	$self->vocab;

	# Link check
	$self->link;

	return 1;
}

sub syntax {
	my ($self) = @_;
	my $step = $self->{step};
	my $xml = $self->{xml};
	my $pr = $self->{pr};
	my $uri = $self->{uri};
	my $fragment;
	my $stem = $uri;
	if($uri =~ /(.*)#(.*)/) {
		$stem = $1;
		$fragment = $2;
	}

	# Message differs between well known location file and normal PRF
	my $name = "Policy file";
	my $name2 = "<tt>$uri</tt>";

	# Initial Message
	$pr->step($step, 1, "Syntax check");
	if($stem eq $self->{prf_uri}) {
		$pr->pri("<p class='result2'>P3P Policy is included in policy reference file.
Syntax check skipped.</p>");
		return 1;
	}

	# Well-formed check
	if(! $xml->well_formed) {
		$self->addError("code", $xml->{error});
		$pr->pri("<p class='result2'>$name is 
<font color='red'>NOT an well-formed XML file</font>.\n");
		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	}

	# Check if the root element exists?
	my $doc = $xml->{doc};
	my $root = $doc->getDocumentElement;
	if(! $root) {
		$pr->pri("<p class='result2'>$name <font color='red'>does not</font>
 look like an XML document.</p>\n");
		return 0;
	}

	# Check if correct namespaces are used
	my $ns = $root->[$Namespace];
	if($ns eq "http://www.w3.org/2000/P3Pv1") {
		# old version
		$self->addError("err", "This file looks like an old version.");
		$pr->pri("<p class='result2'>$name\'s version is old.</p>\n");
		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	} elsif($ns eq "http://www.w3.org/2000/09/15/P3Pv1") {
		# a bit old
		$self->addError("warn", "This file looks like an old version.");
	} elsif($ns eq "http://www.w3.org/2000/10/18/P3Pv1") {
		$self->addError("warn", "This file looks like an old version.");
#	} elsif($ns eq "http://www.w3.org/2001/09/P3Pv1") {
		# OK
	} elsif($ns eq "http://www.w3.org/2000/12/P3Pv1") {
		# OK
	} elsif($ns eq "http://www.w3.org/P3P/validator/20001215/p3p.xml") {
		# OK
	} elsif($ns eq "") {
		# forgot to write xmlns="..."??
		$self->addError("warn", "This XML does not have valid namespace definition.");
	} else {
		# invalid namespace
		$pr->pri("<p class='result2'>$name has invalid namespace 
<tt>$ns</tt>.</p>\n");
		return 0;
	}

	# Check if root element is "POLICY"?
	if($root->getTagName ne "POLICY"
		&& $root->getTagName ne "POLICIES" 
		&& $root->getTagName ne "META") {
		$self->addError("err", "The root elemnt of P3P policy MUST be 
<tt>&lt;POLICY&gt;</tt>, <tt>&lt;POLICIES&gt;</tt>, or <tt>&lt;META&gt;</tt>.");
		$pr->pri("<p class='result2'>$name <font color='red'>does not</font>
 look like a P3P policy file.</p>\n");
		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	}

	# Validation with XSV
	if(! $xml->validate) {
		my $errors = $xml->{error};
		foreach my $mes (@{$errors}) {
			$self->addError("err", $mes);
		}
		$pr->pri("<p class='result2'>$name has 
<font color='red'>syntax errors</font>.</p>\n");
		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	}

	# No Error!!
	$pr->pri("<p class='result2'>$name has 
<font color='blue'>no syntax errors</font>.</p>\n");
	$pr->printError($self->errors);
	$self->clearError;
	return 1;
}

sub vocab {
	my ($self) = @_;

	# Variable settings
	my $step = $self->{step};
	my $pr = $self->{pr};
	my $xml = $self->{xml};

	# Initial Message
	$pr->step($step, 2, "Vocabulary check");

	# compile basedata schema
	my $basedata = "http://www.w3.org/P3P/validator/20001215/base.xml";

	my $doc = $xml->{doc};
	if(!$doc) {
		return 0;
	}

	my $has_error = 0;
	my %dicdic;
	foreach my $data_group_elem ($doc->getElementsByTagName("DATA-GROUP")){
		my $node = $data_group_elem->getAttributeNode("base");
		my $base = $data_group_elem->getAttribute("base");
		if(!$base){
			# [base = ""] ? or [(nothing)] ?
			# if(nothing) => absolute URI or basedata schema
			if(!$node){
				# in case [ref = "absolute URI"]
				$base = $basedata;
			}
			# if([base=""]) => local(schema in policy)
			if($node){
				$base = $self->{uri};
			}
		}

		my $elem = $data_group_elem->getFirstChild;
		while($elem){
			if($elem->getTagName ne "DATA") {
				$elem = $elem->getNextSibling;
				next;
			}

			my $ref = $elem->getAttribute("ref");
			my $ref2 = P3P::Common::absoluteURI($ref, $base);
			my $ref3;
			my $dsf;
			if($ref2 =~ /(.+)#(.+)/) {
				$dsf = $1;
				$ref3 = $2;
			} elsif($base ne $basedata) {
				$has_error = 1;
				$self->addError("err", "line ".$elem->[$Line].": <tt>$ref</tt> is invalid user defined data element.");
				$elem = $elem->getNextSibling;
				next;
			} else {
				$has_error = 1;
				$self->addError("err", "line ".$elem->[$Line].": <tt>$ref</tt> is invalid  data element (maybe # is missing).");
				$elem = $elem->getNextSibling;
				next;
			}

			my $dic = $dicdic{$dsf};
			if(!$dic) {
				$dic = new P3P::DataSchema;
				$dic->uri($dsf);
				my $result = $dic->makeDic;
				if($result ne "no error") {
					$dicdic{$dsf} = "error";
					$has_error = 1;
					$self->addError("err", "line ".$elem->[$Line].": ".$dic->{err_msg});
					$elem = $elem->getNextSibling;
					next;
				} else {
					$dicdic{$dsf} = $dic;
				}
			} elsif($dic eq "error") {
				$elem = $elem->getNextSibling;
				next;
			}

			my $res = $dic->dataExist($ref3);
			if(! $res) {
				$has_error = 1;
				$self->addError("err","line ".$elem->[$Line].": <tt>$ref</tt> is invalid base data element.");
			}

			my $flag = P3P::Common::has_category($elem);
			if($res eq "no_category" && $flag eq "no_category") {
				$has_error = 1;
				$self->addError("err", "line ".$elem->[$Line].": <tt>$ref</tt> 
is a variable-category data element. 
Categories must be specified when using <tt>$ref</tt>.");
			} elsif(0 && $res eq "has_category" && $flag eq "has_category") {
				$self->addError("mes", "line ".$elem->[$Line].": <tt>$ref</tt> 
is a fixed-category data element. 
You don't need to specify categories here.");
			}
			$elem = $elem->getNextSibling;
		}
	}

	if($has_error) {
		$pr->pri("<p class='result2'>Policy file has 
<font color='red'>vocabulary errors</font>.");
	} else {
		$pr->pri("<p class='result2'>Policy file has 
<font color='blue'>no vocabulary errors</font>.");
	}

	$pr->printError($self->errors);
	$self->clearError;

	return 1;
}
#############################################################################
#--Shojima modified part--(END)
#############################################################################

sub link {
	my ($self) = @_;

	# Variable settings
	my $step = $self->{step};
	my $pr = $self->{pr};
	my $xml = $self->{xml};
	my $uri = $self->{uri};
	my $prf_uri = $self->{prf_uri};
	my $fragment;
	my $stem;
	if($uri =~ /(.*)#(.*)/) {
		$stem = $1;
		$fragment = $2;
	}

	# Initial Message
	$pr->step($step, 3, "Link check");

	my $doc = $xml->{doc};
	if(!$doc) {
		return 0;
	}

	my $res = 1;
	if(! $self->check_link($doc, "POLICY", "discuri")) { $res = 0; }
	if(! $self->check_link($doc, "POLICY", "opturi")) { $res = 0; }
	if(! $self->check_link($doc, "DISPUTES", "service")) { $res = 0; }
	if(! $self->check_link($doc, "IMG", "src")) { $res = 0; }

	if($res) {
		$pr->pri("<p class='result2'>Policy file has 
<font color='blue'>no link errors</font>.");
	} else {
		$pr->pri("<p class='result2'>Policy file has 
<font color='red'>link errors</font>.");
	}

	$pr->printError($self->errors);
	$self->clearError;

	return 1;
}

sub check_link {
	my ($self, $doc, $tag, $atname) = @_;

	my $uri = $self->{uri};
	foreach my $elem ($doc->getElementsByTagName($tag)) {
		my $line = $elem->[$Line];
		my $value = $elem->getAttribute($atname);

		if($value) {
			my $xml = new P3P::XML;
			my $xuri = P3P::Common::absoluteURI($value, $uri);
			unless($xuri =~ /^http\S?:\/\/.+\//) {
				$xuri = $xuri."/";
			}
			$xml->setURI($xuri);
			if($xml->access eq 200) {
				$self->addError("mes", "line ".$line.": 
<tt>$atname</tt> attribute of <tt>&lt;$tag&gt;</tt> element 
<font color='blue'>can be</font> accessed.");
			} else {
				$self->addError("warn", "line ".$line.": 
<tt>$atname</tt> attribute of <tt>&lt;$tag&gt;</tt> element 
<font color='red'>can NOT be</font> accessed. <br>".$xml->{error});
				return 0;
			}
		}
	}
	return 1;
}

sub addError {
	my ($self, $status, $mes) = @_;
	my $err = new P3P::Error;
	$err->status($status);
	$err->message($mes);
	push(@{$self->errors}, $err);
}

sub clearError {
	my ($self) = @_;
	my @new_errors;
	$self->{errors} = \@new_errors;
}

sub errors {
	my ($self) = @_;
	return $self->{errors};
}

# module return code
1;

__END__
