#####################################################################
#
# Perl module: P3P::XML
#
######################################################################
#
# $Id: xml.pl,v 1.7 2000/10/18 19:47:00 koike Exp $
# Created by Yuichi Koike (koike@w3.org)
#

use strict;
use XML::DOM;
use LWP::UserAgent;
use HTTP::Request::Common qw(POST);

my $Namespace = 10;
my $Line      = 11;
my $Prefix    = 12;

######################################################################
package P3P::XML;
######################################################################

#
# P3P::XML is derived from XML::DOM::Parser module.
# It parses XML document, and builds DOM tree.
# However, it does not create any text nodes,which are composed of
# only white spaces, CR, and LF.
#
# It also add namespace and line information to the element.
# $elem->[$Namespace] gives the namespace, to which the element belongs
# $elem->[$Line] gives the line number, where element appears
# $elem->[$Prefix] gives the namespace prefix
#

use vars qw ( @ISA );
@ISA = qw ( XML::DOM::Parser );

sub new {
    my ($class, %args) = @_;
    $args{Style} = 'P3P';
	$args{Namespaces} = 1;
	if(! $args{ErrorContext}) {
		$args{ErrorContext} = 2;
	}
	if(! $args{ProtocolEncoding}) {
		$args{ProtocolEncoding} = 'UTF-8';
	}
    $class->XML::Parser::new (%args);
}

#
# parse XML document stored in memory
#	$content contains XML document expressed as a string
#	returns XML::DOM::Document based on the given XML document
#
sub parse {
	my ($self, $content) = @_;

	my $doc = $self->XML::DOM::Parser::parse($content);
	if(! $doc) {
		return 0;
	}

	# remove unnecessary (= includes only white spaces) nodes
	$self->{doc} = $doc;
	return $doc;
}

#
# debug print
#	$element is an XML::DOM::Element
#
sub print {
	my ($self, $element, $num, $namespace) = @_;

	# if $element is null, get root element
	if(! $element) {
		my $doc = $self->{doc};
		$element = $doc->getDocumentElement;
	}

	for(my $i=0;$i<$num;$i++) { print " "; }
	print "<";
	my $prefix = $element->[$Prefix];
	my $tagName;
	if($prefix && $prefix ne "#default") {
		$tagName = $prefix.":";
	}
	$tagName = $tagName.$element->getTagName;
	print $tagName;

	my $attlist = $element->getAttributes;
	for(my $i=0; $i<$attlist->getLength; $i++) {
		my $attnode = $attlist->item($i);
		print " ", $attnode->getName, "=\"", $attnode->getValue, "\"";
	}

	if(! $element->hasChildNodes) {
		print "/>\n";
	} else {
		print ">\n";
		my $child = $element->getFirstChild;
		while($child) {
			if($child->getNodeType eq XML::DOM::TEXT_NODE) {
				print $child->getData, "\n";
			} else {
				$self->print($child, $num+1);
			}
			$child = $child->getNextSibling;
		}
		
		for(my $i=0;$i<$num;$i++) { print " "; }
		print "</", $tagName, ">\n";
	}
}

sub setURI {
	my ($self, $uri) = @_;
	$self->{URI} = $uri;

	# initialize instance variables
	$self->{access} = 0;
	$self->{parsed} = 0;
	$self->{content} = "";
	$self->{error} = "";
	$self->{redirectURI} = "";
	$self->{doc} = 0;
}

#
# Check if the URI is accessible or not.
# returns HTTP code (200, 302, or 404...etc.)
# redirected URI is stored in $self->{redirectURI}
# content is stored in $self->{content}
# content_type is stored in $self->{content_type}
#
sub access {
	my ($self) = @_;

	# set user agent
	my $ua = new LWP::UserAgent;
	$ua->agent("P3P Protocol Checker " . $ua->agent);
	$ua->env_proxy;

	# send request
	my $req = HTTP::Request->new(GET => $self->{URI});

	# get response and treat errors
	my $res = $ua->request($req);
	if($res->is_error || $res->code ne 200) {
		$self->{error} = $res->code." ".$res->message;
		$self->{access_error} = $self->{error};
	} elsif($self->{URI} ne $res->base) {
		# deal with redirection
		$self->{redirectURI} = $res->base;
	}
	$self->{response} = $res;
	$self->{content} = $res->content;
	$self->{content_type} = $res->content_type;

	# set flag
	$self->{access} = 1;
	$self->{code} = $res->code;

	return $res->code;
}

#
# Check if the URI is well-formed XML
#
sub well_formed {
	my ($self) = @_;

	# access check
	if(! $self->{access}) {
		$self->access();
	}

	if(! $self->{content}) {
		$self->{error} = "URI is not accessible";
		return 0;
	}

	my $doc = eval '$self->parse($self->{content})';
	if(! $doc) {
		my $encoded = HTML::Entities::encode($@);
		# remove "at c:/Others/Perl/site/lib/XML/Parser.pm line 168"
		$encoded =~ s/&#13;//g;
		$encoded =~ s/(.*)\n(.*)\n(.*)/\1/gs;
		$self->{error} = $encoded;
		return 0;
	} else {
		return 1;
	}
}

sub validate {
	my ($self, $schema) = @_;

	# prepare for error message
	my @errors;
	$self->{error} = \@errors;

	# access check
	if(! $self->{access}) {
		$self->access();
	}
	if(! $self->{content}) {
		push(@errors, "URI is not accessible");
		return 0;
	}

	# change namespace URI to XML schema file URI
	my $schema2;
	if($schema eq "http://www.w3.org/2000/P3Pv1") {
		$schema2 = "http://www.w3.org/P3P/validator/p3p.xml";
	}
	my $content = $self->{content};
	if($schema2) {
		$content =~ s/xmlns\s*=\s*(\"|\')$schema(\"|\')/xmlns=$1$schema2$2/g;
		$content =~ s/xmlns:(\S*)\s*=\s*(\"|\')$schema(\"|\')/xmlns:$1=$2$schema2$3/g;
	}

	# Call XML Schema Validator (XSV)
	my $ua = new LWP::UserAgent;
	$ua->agent("P3P Validator");
	$ua->no_proxy;
	my $req = HTTP::Request::Common::POST('http://www.w3.org/2000/09/webdata/xsv',
		Content_Type => 'form-data',
		Content => [ docFile => [undef, '/p3p/policy.xml', Content => $content],
						keepGoing => 'on',
						style => 'text' ]);
	my $res = $ua->request($req);

	# Parse the XSV's result
	my $xml = new P3P::XML;
	$xml->{access} = 1;
	$xml->{content} = $res->content;
	$xml->well_formed;
	my $doc = $xml->{doc};

	# invalid response
	if((! $doc)
		|| (! $doc->getDocumentElement)
		|| $doc->getDocumentElement->getTagName ne "xsv") {
		push(@errors, "Unknown error occured.");
		return 0;
	}

	my $root = $doc->getDocumentElement;
	my $child = $root->getFirstChild;
	while($child) {
		if($child->getTagName eq "invalid") {
			my $mes = "line ".($child->getAttribute("line")).": ";
			$mes = $mes.($child->getFirstChild->getData);
			push(@errors, $mes);
		}
		$child = $child->getNextSibling;
	}

	return ($root->getAttribute("instanceErrors") eq "0");
}

######################################################################
package XML::Parser::P3P;
######################################################################

#
# XML::Parser::P3P a customized XML parser for P3P::XML
#

my %NSDic;

BEGIN {
	$XML::Parser::Built_In_Styles{P3P} = 1;
	%NSDic = {};
}

sub Init {
	XML::Parser::Dom::Init(@_);
}

sub Final {
	XML::Parser::Dom::Final(@_);
}


#
# Ignore text nodes which includes only LF, CR and white spaces.
#
sub Char {
    my ($self, $str) = @_;
    $str =~ s/\s|\n|\r//g;
    if($str) {
		XML::Parser::Dom::Char(@_);
	}
}

sub Start {
	my ($expat, $elem, @attr) = @_;


	# make namespace dictionary
	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);
	if(! $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]);
		if(! $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};
	}
}

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(@_);
}

# module return code
1;

__END__
