######################################################################
#
# Perl module: P3P::PolicyCheck
#
######################################################################
#
# $Id: policycheck.pl,v 1.5 2002/12/01 11:30:12 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
	my $escaped_uri = URI::Escape::uri_escape($uri, "\0-\377");
	$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=$escaped_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");
		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	}

	# Check if correct namespaces are used
	my $root_status = 0;
	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") {
		$self->addError("warn", "This file looks like an old version.");
		$root_status = 1;
	} elsif($ns eq "http://www.w3.org/2000/10/18/P3Pv1") {
		$self->addError("warn", "This file looks like an old version.");
		$root_status = 1;
	} elsif($ns eq "http://www.w3.org/P3P/validator/20001215/p3p.xml") {
		# debug purpoes
		$self->addError("mes", "This file is not compatible with the latest P3P spec (maybe compatible with P3P Candidate Recommendation).");
		$root_status = 1;
	} elsif($ns eq "http://www.w3.org/2000/12/P3Pv1") {
		$self->addError("mes", "This file is not compatible with the latest P3P spec (maybe compatible with P3P Candidate Recommendation).");
		$root_status = 1;
	} elsif($ns eq "http://www.w3.org/2001/09/P3Pv1") {
		$self->addError("mes", "This file is not compatible with the latest P3P spec (maybe compatible with the P3P spec at Sep, 2001).");
		$root_status = 2;
	} elsif($ns eq "http://www.w3.org/2002/01/P3Pv1") {
		# OK
		$root_status = 2;
	} 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");
		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	}

	# Check if root element is "POLICY"?
	my $has_error = 0;
	my $rtn = $root->getTagName;
	if($root_status eq 1 && $rtn ne "POLICY" && $rtn ne "POLICIES" && $rtn 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;
	} elsif($root_status eq 2 && $rtn ne "POLICIES" && $rtn ne "META") {
		if($rtn eq "POLICY") {
			$has_error = 1;
			$self->addError("err", "The root elemnt of P3P policy MUST be 
<tt>&lt;POLICIES&gt;</tt>, or <tt>&lt;META&gt;</tt>.");
		} else {
			$self->addError("err", "The root elemnt of P3P policy MUST be 
<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);
		}
		$has_error = 1;
	}

	# opturi checking
	foreach my $pol ($root->getElementsByTagName("POLICY")) {
		if($pol->getAttribute("opturi") eq "") {
			if(! $self->opturi($pol, "PURPOSE")) {
				$has_error = 1;
			}
			if(! $self->opturi($pol, "RECIPIENT")) {
				$has_error = 1;
			}
		}
	}

	# <DATA> checking
	foreach my $pol ($root->getElementsByTagName("POLICY")) {
		if($pol->getAttribute("opturi") eq "") {
			if(! $self->opturi($pol, "PURPOSE")) {
				$has_error = 1;
			}
			if(! $self->opturi($pol, "RECIPIENT")) {
				$has_error = 1;
			}
		}
	}

	# EXPIRY check
	my $exp_error = 0;
	if($root->getTagName() eq "POLICIES") {
		my $expiry;
		my $child = $root->getFirstChild(); 
		while($child) {
			if($child->getNodeType eq XML::DOM::ELEMENT_NODE
				&& $child->getTagName eq "EXPIRY") {

				# <EXPIRY> element exists
				my $expiry = $child;
				my $mage = $expiry->getAttribute("max-age");
				my $edate = $expiry->getAttribute("date");

				if($mage && $edate) {
					# only one of "max-age" or "date" can be used
					$exp_error = 1;
					my $mes = "line ".$expiry->[$Line].": <tt>max-age</tt> and 
<tt>date</tt> attributes cannot be used at the same time. Use only one of them.";
					$self->addError("err", $mes);
				} elsif($edate) {
					my $etime = HTTP::Date::str2time($edate);
					if(! $etime) {
						my $mes = "line ".$expiry->[$Line].": The format of
<tt>date</tt> attribute is invalid. The valid format is like <tt>'Sat, 30 Nov 2002 11:24:17 +0900'</tt>";
						$self->addError("warn", $mes);
					} else {
						if(time() > $etime) {
							$exp_error = 1;
							my $mes = "line ".$expiry->[$Line].": This policy 
file was expired at <tt>$edate</tt>";
							$self->addError("err", $mes);
						}
					}
				}

				if($exp_error) {
					$pr->pri("<p class='result2'>$name has 
<font color='red'>syntax errors or warnings</font>.</p>\n");
					$pr->printError($self->errors);
					$self->clearError;
					return 0;
				}

				last;
			}
			$child = $child->getNextSibling();
		}
	}

	# No Error!!
	if($has_error) {
		$pr->pri("<p class='result2'>$name has
<font color='red'>syntax errors or warnings</font>.</p>\n");
		$pr->printError($self->errors);
		$self->clearError;
	} else {
		$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 opturi {
	my ($self, $pol, $tagName) = @_;
	my $no_error = 1;

	foreach my $pur ($pol->getElementsByTagName($tagName)) {
		my $pur_child = $pur->getFirstChild;
		while($pur_child) {
			if($pur_child->getNodeType eq XML::DOM::ELEMENT_NODE) {
				my $rv = $pur_child->getAttribute("required");
				if($rv eq "opt-out" || $rv eq "opt-in") {
					$no_error = 0;
					$self->addError("err", "line ".$pur_child->[$Line].": 
When the value of <tt>required</tt> attribute is <tt>opt-out</tt> or <tt>opt-in</tt>, 
you must specify <tt>opturi</tt> value in the <tt>&lt;POLICY&gt</tt> element 
(line ".$pol->[$Line].").");
				}
			}
			$pur_child = $pur_child->getNextSibling;
		}
	}

	return $no_error;
}

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");

	my $doc = $xml->{doc};
	if(!$doc) {
		return 0;
	}
	my $root = $doc->getDocumentElement;
	my $ns = $root->[$Namespace];

	# compile basedata schema
	my $basedata = "http://www.w3.org/P3P/validator/20020128/base.xml";
	if($ns eq "http://www.w3.org/2000/09/15/P3Pv1") {
		$basedata = "http://www.w3.org/P3P/validator/20000915/base.xml";
	} elsif($ns eq "http://www.w3.org/2000/10/18/P3Pv1") {
		$basedata = "http://www.w3.org/P3P/validator/20001018/base.xml";
	} elsif($ns eq "http://www.w3.org/P3P/validator/20001215/p3p.xml") {
		$basedata = "http://www.w3.org/P3P/validator/20001215/base.xml";
	} elsif($ns eq "http://www.w3.org/2000/12/P3Pv1") {
		$basedata = "http://www.w3.org/P3P/validator/20001215/base.xml";
	} elsif($ns eq "http://www.w3.org/2001/09/P3Pv1") {
		$basedata = "http://www.w3.org/P3P/validator/20010928/base.xml";
	} elsif($ns eq "http://www.w3.org/2002/01/P3Pv1") {
		$basedata = "http://www.w3.org/P3P/validator/20020128/base.xml";
	}

	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($ref =~ /^#(.+)/) {
				$ref3 = $1;
				$dsf = "##embedded";
			} 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 an invalid data element (maybe # is missing at the top).");
				$elem = $elem->getNextSibling;
				next;
			}

			# substitute base data schema URI
			if($dsf eq "http://www.w3.org/TR/P3P/base") {
				$dsf = $basedata;
			}

			my $dic = $dicdic{$dsf};
			if(!$dic) {
				$dic = new P3P::DataSchema;
				$dic->uri($dsf);
				if($dsf eq "##embedded") {
					$dic->{embedded} = $xml;
				}
				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 $nullstr = "------------------";
			my $flag = P3P::Common::has_category($elem);
			if($res eq $nullstr && $flag eq $nullstr) {
				$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($res ne $nullstr && $flag ne $nullstr && $res ne $flag) {
				$has_error = 1;
				$self->addError("err", "line ".$elem->[$Line].": <tt>$ref</tt> 
is a fixed-category data element. 
When you specify categories for fixed-category data element in the policy, 
you MUST use exactly the same category set as defined in the data schema.");
			}
			$elem = $elem->getNextSibling;
		}
	}

	if($has_error) {
		$pr->pri("<p class='result2'>Policy file has 
<font color='red'>vocabulary errors or warnings</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 or warnings</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;
			$xml->setURI(P3P::Common::absoluteURI($value, $uri));
			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__
