#! perl
# $Id: appel.pl,v 1.9 2000/08/24 22:19:47 koike Exp $
# Created by Yuichi Koike (koike@w3.org

use strict;
use LWP::UserAgent;
use XML::DOM;

my $Namespace = 10;
my $Line      = 11;
my $Prefix    = 12;

######################################################################
package P3P::XML;
######################################################################

use vars qw ( @ISA );
@ISA = qw ( XML::DOM::Parser );

sub new
{
    my ($class, %args) = @_;
    $args{Style} = 'P3P';
    $args{Namespaces} = 1;
	$args{ErrorContext} = 2;
	$args{ProtocolEncoding} = 'iso-8859-1';
    $class->XML::Parser::new (%args);
}

sub addNamespace {
	my ($self, $uri, $prefix) = @_;

	unless($self->{NSDic}) {
		my %dic;
		$self->{NSDic} = \%dic;
	}

	my $dic = $self->{NSDic};
	$$dic{$uri} = $prefix;
}

sub getNamespace {
	my ($self, $uri) = @_;

	my $dic = $self->{NSDic};
	return $$dic{$uri};
}

# parse XML document stored in memory
sub parse {
	my ($self, $content) = @_;

	my $doc = $self->XML::DOM::Parser::parse($content);
	unless($doc) {
		return 0;
	}

	# remove unnecessary (= includes only white spaces) nodes
	$self->{doc} = $doc;
	return $doc;
}

# debug print
sub print {
	my ($self, $element) = @_;

	$self->{Color} = "";
	my $buf = $self->print_sub($element, 0);
	return $buf."</font>";
}

sub setColor {
	my ($self, $color) = @_;
	my $buf;
	if($self->{Color}) {
		$buf = "</font>";
	}
	if($color && $color ne $self->{Color}) {
		$buf = $buf."<font color='".$color."'>";
	}
	return $buf;
}


my $col_control  = "#c00000";

my $col0_tagName = "blue";
my $col0_attName = "#000080";
my $col0_attVal  = "#000040";
my $col0_text    = "black";

my $col1_tagName = "red";
my $col1_attName = "#800000";
my $col1_attVal  = "#60000";
my $col1_text    = "#400000";

sub print_sub {
	my ($self, $element, $num) = @_;
	my $buf;

	# fill the spaces
	for(my $i=0; $i<$num; $i++) {
		$buf = $buf."  ";
	}

	# check if it is "match" element
	my $match = $element->getAttribute($P3P::APPEL::MATCH) eq $P3P::APPEL::TRUE ? 1 : 0;

	# <
	$buf = $buf.$self->setColor($col_control)."&lt;";

	# tag name
	$buf = $buf.$self->setColor($match ? $col1_tagName : $col0_tagName);
	my $prefix = $element->[$Prefix];
	if($prefix ne "#default") {
		$buf = $buf.$prefix."::";
	}
	$buf = $buf.$element->getTagName;

	# attribute
	my $attlist = $element->getAttributes;
	for(my $i=0; $i<$attlist->getLength; $i++) {
		my $attnode = $attlist->item($i);
		my $name = $attnode->getName;
		my $value = $attnode->getValue;

		# skip match attribute
		if($name eq $P3P::APPEL::MATCH) {
			next;
		}

		# attribute name
		my $prefix2 = $attnode->[$Prefix];
		if($prefix2 ne $prefix) {
			$name = " ".$prefix2."::".$name;
		} else {
			$name = " ".$name;
		}
		$buf = $buf.$self->setColor($match ? $col1_attName : $col0_attName);
		$buf = $buf.$name;

		# ="
		$buf = $buf.$self->setColor($col_control);
		$buf = $buf."=&quot;";

		# attribute value
		$buf = $buf.$self->setColor($match ? $col1_attVal : $col0_attVal);
		$buf = $buf.$value;

		# "
		$buf = $buf.$self->setColor($col_control);
		$buf = $buf."&quot;";
	}

	unless($element->hasChildNodes) {
		$buf = $buf.$self->setColor($col_control)."/&gt;\n";
	} else {
		$buf = $buf.$self->setColor($col_control)."&gt;";
		my $child = $element->getFirstChild;
		my $linefeed = 0;
		while($child) {
			if($child->getNodeType eq XML::DOM::TEXT_NODE) {
				$buf = $buf.$self->setColor($match ? $col1_text : $col0_text);
				$buf = $buf.$child->getData;
			} else {
				unless($linefeed) {
					$linefeed = 1;
					$buf = $buf."\n";
				}
				$buf = $buf.$self->print_sub($child, $num + 1);
			}
			$child = $child->getNextSibling;
		}
		if($linefeed) {
			for(my $i=0; $i<$num; $i++) {
				$buf = $buf."  ";
			}
		}
		$buf = $buf.$self->setColor($col_control)."&lt;/";
		$buf = $buf.$self->setColor($match ? $col1_tagName : $col0_tagName);
		$buf = $buf.$element->getTagName;
		$buf = $buf.$self->setColor($col_control)."&gt;\n";
	}
	return $buf;
}

# parse XML document stored in a file
sub parsefile {
	my ($self, $fname) = @_;

	unless(open AAA, $fname) {
		return 0;
	}
	my $content;
	while(<AAA>) {
		$content = $content.$_;
	}
	close AAA;

	return $self->parse($content);
}

sub koike {
	return 1;
}

# parse XML document stored on the net
sub parseURI {
	my ($self, $uri) = @_;

	# retrieve policy from the net
	my $ua = new LWP::UserAgent;
	$ua->agent("P3P Parser" . $ua->agent);
	$ua->env_proxy;
	my $req = HTTP::Request->new(GET => $uri);
	my $res = $ua->request($req);
	my $content = $res->content;
	unless($content) {
		return 0;
	}

	# successfully retrieved policy from the net
	return $self->parse($content);
}

######################################################################
package P3P::Policy;
######################################################################

sub new {
	my ($class, %args) = @_;
    bless \%args, $class;
}

######################################################################
package P3P::APPEL;
######################################################################

use vars qw(
	$NS
	$RULESET
	$RULE
	$REQUEST
	$REQUEST_GROUP
	$URI
	$OTHERWISE
	$P3P_POLICY
	$P3P_NS
	$MATCH
	$TRUE
	$FALSE
	$CONNECTIVE
	$OR
	$AND
	$OR_EXACT
	$AND_EXACT
);

BEGIN {
	$NS            = "http://www.w3.org/2000/APPEL";
	$RULESET       = "RULESET";
	$RULE          = "RULE";
	$REQUEST       = "REQUEST";
	$REQUEST_GROUP = "REQUEST-GROUP";
	$URI           = "uri";
	$OTHERWISE     = "OTHERWISE";
	$P3P_POLICY    = "POLICY";
	$P3P_NS        = "http://www.w3.org/2000/P3Pv1";
	$MATCH         = "match";
	$TRUE          = "true";
	$FALSE         = "false";
	$CONNECTIVE    = "connective";
	$OR            = "or";
	$AND           = "and";
	$OR_EXACT      = "or-exact";
	$AND_EXACT     = "and-exact";
}

sub new {
	my ($class, %args) = @_;
    bless \%args, $class;
}

# Compare the APPEL ruleset and P3P policy
# Return 1, if a rule matches the policy.
# Matching rule is stored in $self->{match_rule} 
# 
# Receive
#   P3P policy (P3P::Policy)
#   URI (string)
# Return
#   APPEL rule (XML::DOM::Element)
sub evaluate {
	my ($self, $policy, $uri) = @_;
	$self->{policy} = $policy;
	$self->{uri} = $uri;

	# check if rule matches the policy
	my $rule = $self->findRule;
	while($rule) {
		my $result = $self->ruleMatch($rule);
		if($result) {
			$self->{match_rule} = $rule;
			return 1;
		}
		$rule = $rule->getNextSibling;
	}

	return 0;
}

# Receive
# Return
#   APPEL rule (XML::DOM::Element)
sub findRule {
	my ($self) = @_;

	my $doc = $self->{XML};
	unless($doc) {
		$self->{Error} = "No XML document object";
		return 0;
	}
	my $root = $doc->getDocumentElement;
	unless($root) {
		$self->{Error} = "No root element";
		return 0;
	}
	if($root->getTagName ne $P3P::APPEL::RULESET) {
		$self->{Error} = "Not an APPEL document";
		return 0;
	}
	if($root->[$Namespace] ne $P3P::APPEL::NS) {
		$self->{Error} = "Not an APPEL document";
		return 0;
	}

	my $rule = $root->getFirstChild;
	unless($rule) {
		$self->{Error} = "No RULE element in the APPEL document";
		return 0;
	}
	if($rule->getTagName ne $P3P::APPEL::RULE || $rule->[$Namespace] ne $P3P::APPEL::NS) {
		$self->{Error} = "Invalid APPEL document";
		return 0;
	}

	return $rule;
}

# Receive
#   APPEL rule (XML::DOM::Element)
# Return
#   match or not as 1 or 0
sub ruleMatch {
	my ($self, $rule) = @_;
	my $policy = $self->{policy};
	my $uri = $self->{uri};
	$self->{Error} = "";

	# getting the contents of <APPEL:RULE>
	my $child = $rule->getFirstChild;
	unless($child) {
		$self->{Error} = "No element in <APPEL:RULE>";
		return 0;
	}

	# dealing with <APPEL:REQUEST>
	if($child->getTagName eq $P3P::APPEL::REQUEST_GROUP  && $child->[$Namespace] eq $P3P::APPEL::NS) {
		# coming soon....
	}

	# dealing with <APPEL:OTHERWISE>
	if($child->getTagName eq $P3P::APPEL::OTHERWISE && $child->[$Namespace] eq $P3P::APPEL::NS) {
		return 1;
	}

	# dealing with <P3P:POLICY>
	if($child->getTagName eq $P3P::APPEL::P3P_POLICY && $child->[$Namespace] eq $P3P::APPEL::P3P_NS) {
		return $self->expressionMatch($child, $policy->{XML}->getDocumentElement);
	}

	# error
	$self->{Error} = "Invalid elements in <APPEL:RULE>";
	return 0;
}


# Receive
#   APPEL rule (XML::DOM::Element)
#   part of P3P policy (XML::DOM::Element)
# Return
#   match or not as 1 or 0
sub expressionMatch {
	my ($self, $express, $pol) = @_;

	# check if $express itself matches...
	my $res = $self->simpleMatch($express, $pol);
	unless($res) {
		return 0;
	}

	# no child -> success
	my $child = $express->getFirstChild;
	unless($child) {
		$pol->setAttribute($P3P::APPEL::MATCH, $P3P::APPEL::TRUE);
		my $atnode = $pol->getAttributeNode($P3P::APPEL::MATCH);
		$atnode->[$Namespace] = $P3P::APPEL::NS;
		return 1;
	}

	# dealing with APPEL:connective value
	my $con_node = $express->getAttributeNode($P3P::APPEL::CONNECTIVE);
	my $con_value = $P3P::APPEL::AND_EXACT;
	if($con_node && $con_node->[$Namespace] eq $P3P::APPEL::NS) {
		$con_value = $con_node->getValue;
	}
	my $anded = ($con_value eq $P3P::APPEL::AND_EXACT || $con_value eq $P3P::APPEL::AND);
	my $ignore = ($con_value eq $P3P::APPEL::OR || $con_value eq $P3P::APPEL::AND);

	# checks children
	my $success = $anded;
	while($child) {
		my $result = 0;
		my $pChild = $pol->getFirstChild;
		while($pChild) {
			my $res = $self->expressionMatch($child, $pChild);
			if($res) {
				$pChild->setAttribute($P3P::APPEL::MATCH, $P3P::APPEL::TRUE);
				my $atnode = $pChild->getAttributeNode($P3P::APPEL::MATCH);
				$atnode->[$Namespace] = $P3P::APPEL::NS;
				$result = 1;
			}
			$pChild = $pChild->getNextSibling;
		}

		# if ANDed only one FALSE result make others fail
		if($anded && ! $result) {
			return 0;
		}

		# if ORed only one TRUE result make others success
		if(! $anded && $result) {
			$success = 1;
		}
		$child = $child->getNextSibling;
	}

	# checks unmatched childres
	my $pChild = $pol->getFirstChild;
	while($pChild) {
		my $match = $pChild->getAttribute($P3P::APPEL::MATCH);
		if($match ne $P3P::APPEL::TRUE) {
			$pChild->setAttribute($P3P::APPEL::MATCH, $P3P::APPEL::FALSE);
			unless($ignore) {
				$success = 0;
			}
		}
		$pChild = $pChild->getNextSibling;
	}

	return $success;
}


# Receive
#   APPEL expression (XML::DOM::Element)
#   part of P3P policy (XML::DOM::Element)
# Return
#   match or not as 1 or 0
sub simpleMatch {
	my ($self, $express, $pol) = @_;

	# tag name must be identical
	if($express->getTagName ne $pol->getTagName) {
		return 0;
	}

	# namespace must be identical
	if($express->[$Namespace] ne $pol->[$Namespace]) {
		return 0;
	}

	# attribute matching
	foreach my $eAttr ($express->getAttributes->getValues) {
		if($eAttr->[$Namespace] eq $P3P::APPEL::P3P_NS) {
			# only P3P attributes are tested
			my $value = $eAttr->getValue;
			my $name = $eAttr->getName;

			# get attributes from P3P policy element
			my $pAttr = $pol->getAttributeNode($name);
			unless($pAttr) {
				# only one failure makes this function fail
				return 0;
			}

			# value matching
			$value =~ s/\*/\.\*/g;
			$value = "^".$value."\$";
			my $pValue = $pAttr->getValue;
			unless($pValue =~ /$value/) {
				return 0;
			}
		}
	}

	return 1;
}

######################################################################
package XML::Parser::P3P;
######################################################################

my %NSDic;

BEGIN {
	$XML::Parser::Built_In_Styles{P3P} = 1;
}

sub Init
{
	XML::Parser::Dom::Init(@_);
	%NSDic = {};
}

sub Final
{
	XML::Parser::Dom::Final(@_);
}

sub Char
{
    my ($self, $str) = @_;
    $str =~ s/\s|\n|\r//g;
    if($str) {
		XML::Parser::Dom::Char(@_);
	}
}

sub Start
{
	my ($expat, $elem, @attr) = @_;

	# check for the new namespace
	foreach my $prefix ($expat->new_ns_prefixes) {
		$NSDic{$expat->expand_ns_prefix($prefix)} = $prefix;
	}

	# determin the namespace of the element
	my $ns = $expat->namespace($elem);
	unless($ns) {
		$ns = $expat->expand_ns_prefix("#default");
	}

	# determin the names space of attributes
	my %atnsdic;
	for(my $i; $i<$#attr; $i+=2) {
		my $name = $attr[$i];
		my $value = $attr[$i+1];
		my $ns2 = $expat->namespace($attr[0]);
		unless($ns2) {
			$ns2 = $ns;
		}
		$atnsdic{$name} = $ns2;
	}

	XML::Parser::Dom::Start(@_);
	$XML::Parser::Dom::_DP_elem->[$Namespace] = $ns;
	$XML::Parser::Dom::_DP_elem->[$Prefix] = $NSDic{$ns};
	$XML::Parser::Dom::_DP_elem->[$Line] = $expat->current_line;
	foreach my $name (keys(%atnsdic)) {
		my $attr = $XML::Parser::Dom::_DP_elem->getAttributeNode($name);
		$attr->[$Namespace] = $atnsdic{$name};
		$attr->[$Prefix] = $NSDic{$atnsdic{$name}};
	}
}

sub End
{
	XML::Parser::Dom::End(@_);
}

sub Default
{
	my ($expat, $str) = @_;
	XML::Parser::Dom::Default(@_);
}

sub CdataStart {
	XML::Parser::Dom::CdataStart(@_);
}

sub CdataEnd {
	XML::Parser::Dom::CdataEnd(@_);
}

sub Comment {
	#XML::Parser::Dom::Comment(@_);
}

sub Doctype {
	XML::Parser::Dom::Doctype(@_);
}

sub Attlist {
	XML::Parser::Dom::Attlist(@_);
}

sub XMLDecl {
	XML::Parser::Dom::XMLDecl(@_);
}

sub Entity {
	XML::Parser::Dom::Entity(@_);
}

sub Unparsed {
	XML::Parser::Dom::Unparsed(@_);
}

sub Element {
	XML::Parser::Dom::Element(@_);
}

sub Proc {
	XML::Parser::Dom::Proc(@_);
}

sub Notation {
	XML::Parser::Dom::Notation(@_);
}

1;
