######################################################################
#
# Perl module: P3P::PolicyRef
#
######################################################################
#
# $Id: policyref.pl,v 1.3 2000/10/11 21:58:26 koike Exp $
# Created by Yuichi Koike (koike@w3.org)
#

use strict;
my $Namespace = 10;
my $Line      = 11;

######################################################################
package P3P::PolicyRef;
######################################################################

sub new {
    my ($class, %args) = @_;
	my $self = bless {}, $class;
	my @errors;
	$self->{errors} = \@errors;
	return $self;
}

sub targetURI {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{target_uri} = $arg;
	} else {
		return $self->{target_uri};
	}
}

sub prf_uri {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{prf_uri} = $arg;
	} else {
		return $self->{prf_uri};
	}
}

sub policy_uri {
	my ($self) = @_;
	return $self->{policy_uri};
}

sub fromHTML {
	my ($self, $flag) = @_;
	$self->{FromHTML} = $flag;
}

sub isWellKnown {
	my ($self) = @_;
	my $wk_uri = P3P::Common::wellknownURI($self->{target_uri});
	return ($self->{prf_uri} eq $wk_uri);
}

sub check {
	my ($self, $step, $pr) = @_;
	$self->{step} = $step;
	$self->{pr} = $pr;
	my $target_uri = $self->{target_uri};

	# Create P3P::XML object
	my $xml = new P3P::XML;
	$self->{xml} = $xml;
	$xml->setURI($self->{prf_uri});

	# Access Check
	if(! $self->access) {
		return 0;
	}

	# Syntax Check
	if(! $self->syntax) {
		return 0;
	}

	# Policy URI Check
	$self->policy;

	return 1;
}

sub access {
	my ($self) = @_;
	my $step = $self->{step};
	my $xml = $self->{xml};
	my $pr = $self->{pr};
	my $prf_uri = $self->{prf_uri};

	# Message differs between well known location file and normal PRF
	my $wkn = "<tt>/w3c/p3p.xml</tt>";
	my $prf = "Policy Reference File";
	my $name = $self->isWellKnown ? $wkn : $prf;
	my $name2 = $self->isWellKnown ? $wkn : "<tt>$prf_uri</tt>";

	# Initial Message
	$pr->pri("<hr>\n");
	my $str = $name;
	$pr->step($step, 0,  $str." Validation");
	$pr->pri("<p><span class='result'>URI:</span> 
<a target='prf' href='header.pl?mode=line&uri=$prf_uri'><tt>$prf_uri</tt></a></p>
");

	# Access check
	$pr->step($step, 1, "Access check");
	$str = "<p class='result2'>$name ";
	my $ret = $xml->access;
	if($ret ne 200) {
		my $mes = $xml->{error}." [uri=<tt>$prf_uri</tt>]";
		$self->addError($self->isWellKnown ? "warn" : "err", $mes);
		$str = $str."<font color='red'>cannot be</font>";
	} else {
		$str = $str."<font color='blue'>can be</font>";

		# printing content type
		my $type = $xml->{content_type};
		$self->addError("mes", "The content type of $name is <b>$type</b>.");
	}
	$pr->pri($str." retrieved.</p>\n");
	$pr->printError($self->errors);
	$self->clearError;

	return ($ret eq 200);
}

sub syntax {
	my ($self) = @_;
	my $step = $self->{step};
	my $pr = $self->{pr};
	my $xml = $self->{xml};
	my $prf_uri = $self->{prf_uri};

	my $wkn = "<tt>/w3c/p3p.xml</tt>";
	my $prf = "Policy Reference File";
	my $name = $self->isWellKnown ? $wkn : $prf;

	# Initial Message
	$pr->step($step, 2, "Syntax check");

	# 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
	} elsif($ns eq "http://www.w3.org/2000/09/15/P3Pv1") {
		# 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 "META"?
	if($root->getTagName ne "META") {
		$pr->pri("<p class='result2'>$name <font color='red'>does not</font>
 look like a P3P policy reference file.</p>\n");

		if($root->getTagName eq "POLICY" || $root->getTagName eq "POLICIES") {
			$self->addError("mes", "This looks like a P3P policy file. 
Policy reference file is expected here.");
		}

		$pr->printError($self->errors);
		$self->clearError;
		return 0;
	}

	# Check if inline policies are included
	my $prefs = $root->getFirstChild;
	my $has_error;
	if($prefs 
		&& $prefs->getNodeType eq XML::DOM::ELEMENT_NODE 
		&& $prefs->getTagName eq "POLICY-REFERENCES") {
		my $child = $prefs->getFirstChild;
		while($child) {
			if($child->getNodeType eq XML::DOM::ELEMENT_NODE
				&& $child->getTagName eq "POLICIES") {
				my $policy = $child->getFirstChild;
				while($policy) {
					if($policy->getNodeType eq XML::DOM::ELEMENT_NODE
						&& $policy->getTagName eq "POLICY") {

						# Inline Policy !!
						my $mes = "line ".$policy->[$Line].": Inline policy is found. 
Policy syntax was also checked here.";
						$self->addError("mes", $mes);

						# `name` attribute
						my $name = $policy->getAttribute("name");
						if(!$name) {
							$has_error = 1;
							$mes = "line ".$policy->[$Line].": mandatory attribute 
<tt>name</tt> is missing in <tt>&lt;POLICY&gt;</tt> element.";
							$self->addError("err", $mes);
						}
					}
					$policy = $policy->getNextSibling;
				}
			}
			$child = $child->getNextSibling;
		}
	}

	# Validation with XSV
	if(! $xml->validate || $has_error) {
		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;
	}

	# Nor 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 policy {
	my ($self) = @_;

	# Variable settings
	my $step = $self->{step};
	my $pr = $self->{pr};
	my $xml = $self->{xml};
	my $prf_uri = $self->{prf_uri};
	my $target_uri = $self->{target_uri};
	my $name = $self->isWellKnown ? "<tt>/w3c/p3p.xml</tt>" : "Policy Reference File";

	# Initial Message
	$pr->step($step, 3, "Policy URI check");

	# make sure that the document exist
	my $doc = $xml->{doc};
	if(! $doc) { return "";}

#
# More work to do...
# If PRF is indicated by HTML <link>, the path is restricted to ...
#

	# search <POLICY-REF> elements
	my $policy;
	my $errFlag = 0;
	foreach my $elem ($doc->getElementsByTagName("POLICY-REF")) {
		my $child = $elem->getFirstChild;
		my $okFlag;

		# search <INCLUDE> or <EXCLUDE> elements
		while($child) {
			my $tag = $child->getTagName;
			if($tag eq "INCLUDE" || $tag eq "EXCLUDE") {
				my $uri = $child->getFirstChild->getData;

				# check if absolute URIs are used
				if($uri =~ /^\S+:\/\//) {
					$self->addError("warn", "line ".$child->[$Line].": 
$tag element <font color='red'>MUST not</font> contain an absolute URI.");
					$errFlag = 1;
				} else {

					# find policy (treating wildcard)
					$uri = P3P::Common::absoluteURI($uri, $prf_uri);
					$uri =~ s/\*/\.\*/g;
					$uri =~ s/\%2A/\\*/g;

					if($self->{target_uri} =~ /$uri/) {
						$okFlag = ($tag eq "INCLUDE");
					}
				}
			}
			$child = $child->getNextSibling;
		}
		if($policy eq "" && $okFlag) {
			$policy = P3P::Common::absoluteURI($elem->getAttribute("about"), $self->{prf_uri});
		}
	}

	# Check if all policies can be accessed
	foreach my $elem ($doc->getElementsByTagName("POLICY-REF")) {
		my $line = $elem->[$Line];
		my $value = $elem->getAttribute("about");

		if($value) {
			my $uri = P3P::Common::absoluteURI($value, $prf_uri);
			my $res = $self->exist($uri);
			if($res eq "yes") {
				my $mes = "P3P policy indicated at line ".$line." 
<font color='blue'>can be</font> accessed. <br>";
				$self->addError("mes", $mes);
			} elsif($res eq "no_elem") {
				my $mes = "The target document 
<font color='red'>does NOT</font> include an appropriate element for 
the P3P policy indicated at line ".$line;
				$self->addError((($policy eq $uri) ? "err" : "warn"), $mes);
				$errFlag = 1;
			} else {
				my $mes = "P3P policy indicated at line ".$line." 
<font color='red'>can NOT</font> be accessed. <br>".$res;
				$self->addError((($policy eq $uri) ? "err" : "warn"), $mes);
				$errFlag = 1;
			}
		}
	}


	if($errFlag) {
		$pr->pri("<p class='result2'>$name has 
<font color='red'>some warnings/errors</font>.</p>\n");
	} else {
		$pr->pri("<p class='result2'>$name has 
<font color='blue'>no warnings/errors</font>.</p>\n");
	}
	$pr->printError($self->errors);
	$self->clearError;

	if($policy) {
		$self->{policy_uri} = $policy;
		$pr->pri("<p class='result'>P3P policy for 
<tt>$target_uri</tt> is [<tt>$policy</tt>]\n</p>");
	} else {
		$self->{policy_uri} = "";
		$pr->pri("<p class='result'>$name does not specify P3P policy 
for <tt>$target_uri</tt>\n</p>");
	}

	return 1;
}

sub exist {
	my ($self, $uri) = @_;

	my $fragment;
	if($uri =~ s/(.*)#(.*)/$1/) {
		$fragment = $2;
	}

	my $xml = $self->getPolicy($uri);

	# No contents
	if($xml->{code} ne 200) {
		return $xml->{access_error};
	}

	# Invalid content
	if(!$xml->{doc}) {
		return "no_elem";
	}

	# if flagment is "", OK
	if(! $fragment) {
		return "yes";
	}

	# Search policy
	foreach my $elem ($xml->{doc}->getElementsByTagName("POLICY")) {
		my $value = $elem->getAttribute("name");
		if($value eq $fragment) {
			return "yes";
		}
	}

	return "no_elem";
}

sub check_uri {
	my ($self) = @_;

	# make sure that the document exist
	my $xml = $self->{xml};
	my $doc = $xml->{doc};
	if(! $doc) {
		return 0;
	}

	# get the URI and site of PRF
	my $prf_uri = $self->{prf_uri};
	my $site = P3P::Common::getSite($prf_uri);

	# search <POLICY-REF> elements
	foreach my $elem ($doc->getElementsByTagName("POLICY-REF")) {
		my $child = $elem->getFirstChild;
		while($child) {
			if($child->getNodeType eq XML::DOM::ELEMENT_NODE) {
				my $tag = $child->getTagName;
				if($tag eq "INCLUDE" || $tag eq "EXCLUDE") {
					my $text = $child->getFirstChild;
					if($text && $text->getNodeType eq XML::DOM::TEXT_NODE) {
						my $uri = $text->getData;
						if($uri =~ /http:\/\//) {
							my $mes = "line ".$elem->[$Line]." <tt>&lt;".$tag."&gt;</tt>";
							$mes = $mes." elemen must contain only relative URIs.";
							$self->addError("err", $mes);
						}
					}
				}
			}
			$child = $child->getNextSibling;
		}
	}

	return 1;
}

sub getPolicy {
	my ($self, $uri) = @_;

	# Dealing with null URI
	if(!$uri) { return ""; }

	# Get dictionary
	my $dic = $self->{content_dic};
	if(! $dic) {
		my %dic;
		$self->{content_dic} = \%dic;
		$dic = \%dic;
	}

	# Get content from cache
	my $cache = ${$dic}{$uri};
	if($cache) { return $cache; }

	# Get content from network
	my $xml = new P3P::XML;
	$xml->setURI($uri);
	$xml->access;
	$xml->well_formed;
	${$dic}{$uri} = $xml;

	return $xml;
}

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__
