#! perl
#
# wrtten by Yuichi Koike ($Id: xml.pl,v 1.1 2000/10/05 21:31:06 koike Exp $)
#
# Modules
use strict;
use XML::DOM;
use HTML::Entities;
require "mylib.pl";

package P3P::XML;

sub new {
	my($class, $fn) = @_;
	bless {pr => 0}, $class;
}

sub error {
	my ($self) = @_;
	return $self->{error};
}

sub errors {
	my ($self) = @_;
	return $self->{errors};
}

sub well_form {
	my ($self, $content) = @_;
#	$content =~ s/^\s+(\S)/$1/;

	my $dom_parser = new XML::DOM::Parser(ErrorContext => 2, Namespaces => 1, ProtocolEncoding => 'UTF-8');
	my $doc = eval '$dom_parser->parse($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, $uri, $schema_name, $orgcon) = @_;
	my $pr = $self->{pr};

	chdir("/home/koike/schema");
	# variables
	my $python = "/usr/bin/python applyschema.py";
	my $lock = "p3p.lck";
	my $result = "result.txt";

	# lock
	open(LOCKFILE, $lock);
	flock(LOCKFILE ,2);

	# print $uri to file
	my $content;
	my %res;
	if($uri =~ /^file:\/\//) {
		$content = $orgcon;
	} else {
		%res = &main'retrieve($uri);
		unless($res{"response"}->content) {
			return 0;
		}
		$content = $res{"response"}->content;
	}
	my $nop3p = 0;
	unless($content =~ s/http:\/\/www\.w3\.org\/2000\/P3Pv1/http:\/\/www\.w3\.org\/P3P\/validator\/p3p\.xml/g) {
		$nop3p = 1;
	}
	my $fake = "/home/koike/validator/20000510/fake.xml";
	my $fakeuri = "file:///home/koike/validator/20000510/fake.xml";
	open(FAKE, "> ".$fake);
	binmode FAKE;
	print FAKE $content;
	close FAKE;

	# execute Henry's XML validator
	open(STDERR, "> $result");
	$ENV{"PYTHONPATH"} = "/home/koike/python";
	system("$python $fakeuri $schema_name");
	close(STDERR);

	# examin the result
	open(CONT, $result);
	my $after_err = "";
	my @errors = ();

	if($nop3p) {
		my $str = "No P3P namespace found.";
		push(@errors, $str." This file does not seem to be a P3P policy.");
	}
	while(<CONT>) {
		if($after_err ne "") {
			chop;
			$after_err = $after_err.$_;
			push(@errors, $after_err);
			$after_err = "";
		} elsif(/^Validation error:/) {
			chop;
			$after_err = $_;
			$after_err =~ s/.*at (line.*)\schar.*/$1:/;
		}
	}
	close CONT;
	unlink($result);
	$self->{errors} = \@errors;

	# remove fake file
	unlink($fake);

	# unlock
	flock(LOCKFILE ,8);
	close LOCKFILE;
	unlink($lock);

	return ($#errors eq -1) ? 1 : 0;
}

package P3P::SchemaParser;

sub new {
	my($class, $fn) = @_;
	bless {pr => 0}, $class;
}

my %datatype;
my %datadef;
my @cur;
my $gmode;

sub parse {
	my ($class, $suri) = @_;
	my $parser = new XML::Parser(ErrorContext => 2, Namespaces => 1, ProtocolEncoding => 'UTF-8');
	$parser->setHandlers(Start => \&p_start, End => \&p_end, Default => \&p_def);
	%datatype = ();
	%datadef = ();
	@cur = ();
	$gmode = 0;
	$parser->parsefile($suri);

	foreach my $key (keys(%datadef)) {
		my @value = @{$datadef{$key}};
		&makedic($key, $value[1], \%datadef, \%datatype);
	}

	return %datadef;
}

sub makedic {
	my ($name, $type, $defdic, $typedic) = @_;
	my $types = $$typedic{$type};
	if($types) {
		foreach my $struct (@{$types}) {
			my $newname = $name.".".$$struct[0];
			my @tmp;
			push(@tmp, $newname);
			push(@tmp, $$struct[1]);
			for(my $count = 2;$count <= $#{$struct};$count++) {
				push(@tmp, $$struct[$count]);
			}
			$$defdic{$newname} = \@tmp;
			makedic($newname, $$struct[1], $defdic, $typedic);
		}
	}
}

sub p_start {
	my ($expat, $elem, @attr) = @_;

	if($elem eq "DATA-TYPE" || $elem eq "DATA-DEF") {
		my $mode = 0;
		@cur = ();
		foreach my $name (@attr) {
			if($mode eq 0) {
				if($name eq "name") {
					$mode = 1;
				} elsif($name eq "typeref") {
					$mode = 2;
				}
			} elsif($mode eq 1) {
				$cur[0] = $name;
				$mode = 0;
			} elsif($mode eq 2) {
				$name =~ s/^#//;
				$cur[1] = $name;
				$mode = 0;
			} elsif($mode eq 3) {
				$mode = 0;
			} else {
				$mode = 3;
			}
		}
	} elsif($elem eq "CATEGORIES") {
		$gmode = 1;
	} elsif($elem eq "DATASCHEMA") {
	} elsif($gmode eq 1) {
		push(@cur, $elem);
	}
}

sub p_end {
	my ($expat, $elem) = @_;

	if($elem eq "DATA-TYPE") {
		$cur[0] =~ s/(.*?)\.(.*)/$2/;
		my $type = $1; 
		unless($datatype{$type}) {
			my @tmp = ();
			$datatype{$type} = \@tmp;
		}
		my @tmp = @cur;
		push (@{$datatype{$type}}, \@tmp);
	} elsif($elem eq "DATA-DEF") {
		my @tmp = @cur;
		$datadef{$cur[0]} = \@tmp;
		my $name = $cur[0];
		while($name =~ s/(.*?\..*?)\..+/$1/) {
			unless($datadef{$name}) {
				my @tmp = ();
				push(@tmp, $name);
				push(@tmp, "unknown");
				$datadef{$name} = \@tmp;
			}
		}
	} elsif($elem eq "CATEGORIES") {
		$gmode = 0;
	}
}

sub p_def {
	my ($expat, $str) = @_;
}


package P3P::DataChecker;

my $need_check = 1;
my @result;
my $dic;
my $content;
my $cur_name;

sub check {
	($content, $dic) = @_;
	my $parser = new XML::Parser(ErrorContext => 2, Namespaces => 1, ProtocolEncoding => 'UTF-8');
	$parser->setHandlers(Start => \&c_start, End => \&c_end, Default => \&c_def);
	$need_check = 1;
	$cur_name = "";
	@result = ();
	$parser->parse($content);
	return @result;
}

sub c_start {
	my ($expat, $elem, @attr) = @_;

	if($elem eq "DATA" && $need_check) {
		my $mode = 0;
		foreach my $name (@attr) {
			if($mode eq 0 && $name eq "ref") {
				$mode = 1;
			} elsif($mode eq 1) {
				unless($name =~ s/^#//) {
					my $err = "line ".$expat->current_line.": <tt>$name</tt>.";
					$err = $err." base data element must start with <tt>#</tt>.";
					push(@result, $err);
				}
				$cur_name = $name;
				unless($$dic{$name}) {
					my $err = "line ".$expat->current_line.": <tt>#$name</tt>";
					$err = $err." is not a valid base data element.";
					push(@result, $err);
				}
				$mode = 0;
			}
		}
	} elsif($elem eq "DATA-GROUP") {
		foreach my $name (@attr) {
			if($name eq "base") {
				$need_check = 0;
			}
		}
	} elsif($elem eq "CATEGORIES") {
		if($cur_name ne "" && $$dic{$cur_name}) {
			if($#{$$dic{$cur_name}} > 1) {
				my $err = "line ".$expat->current_line.": <tt>#$cur_name</tt> ";
				$err = $err."is fixed-category data elements. ";
				$err = $err."Therefore, &lt;CATEGORIES&gt; should not be written here.";
				push(@result, $err);
			}
		}
	}
}

sub c_end {
	my ($expat, $elem) = @_;

	if($elem eq "DATA-GROUP") {
		$need_check = 1;
	} elsif($elem eq "DATA") {
		$cur_name = "";
	}
}

sub c_def {
	my ($expat, $str) = @_;
}

1;
