#! perl
#
# Created by Yuichi Koike ($Id: mylib.pl,v 1.1 2000/10/05 21:31:06 koike Exp $)
#
#
use strict;
use LWP::UserAgent ();
require "jcode.pl";

# Usage:
# 	retrive("http://foo/bar", "GET")
# 	retrive("http://foo/bar.cgi", "POST", "post-data")
# 
# This subroutine retrieves specied URL.
# It resolves the redirection.
# It returns a dictionary composed of:
# 	"response" => response object
# 	"error" => error string
#	"redirect" => redirected URL
sub retrieve {
	# argument
	my ($url, $method, $postdata) = @_;

	# return value
	my %ret;

	# set user agent
	my $ua = new LWP::UserAgent;
	$ua->agent("P3P Protocol Checker" . $ua->agent);
	$ua->env_proxy;

	# send request
	my $req;
	if($method eq "HEAD") {
		$req = HTTP::Request->new(HEAD => $url);
	} elsif($method eq "POST") {
		$req = HTTP::Request->new(POST => $url);
	} else {
		$req = HTTP::Request->new(GET => $url);
	}

	# get response and treat errors
	my $res = $ua->request($req);
	$ret{"response"} = $res;
	if($res->is_error || $res->code ne 200) {
		$ret{"error"} = $res->code." ".$res->message;
	} else {
		# treat redirection
		if($url ne $res->base) {
			$ret{"redirect"} = $res->base;
		}
	}

	return %ret;
}

sub read_params {
	my $type = $_[0];

	my @ret;
	my $buffer;
	if ($type eq "POST") {
		# Form
		read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
		return make_dic($buffer);
	} else {
		# Query String
		my $buffer = $ENV{'QUERY_STRING'};
		return make_dic($buffer);
	}
}

sub make_dic {
	my $buffer = $_[0];

	my @pairs = split(/&/, $buffer);
	my ($pair, $name, $value, %FORM);
	foreach $pair (@pairs)
	{
		($name, $value) = split(/=/, $pair);
		$value =~ tr/+/ /;
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		&jcode'convert(*value, 'euc');
		$FORM{$name} = $value;
	}

	return %FORM;
}

package P3P::Print;

sub new {
	my($class, $fn) = @_;
	bless {warn => "on", mes_str => "", error_happen => 0, warn_happen => 0, gerr => 0}, $class;
}

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

sub clear_gerr {
	my ($self) = @_;
	$self->{gerr} = 0;
}

sub set_warn {
	my ($self, $str) = @_;
	$self->{warn} = $str;
}

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

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

sub clear_ew {
	my ($self) = @_;
	$self->{warn_happen} = 0;
	$self->{error_happen} = 0;
}

sub pri {
	my ($self, $str) = @_;
	print $str;
}

sub print_all {
	my ($self, $str) = @_;

	print $self->{mes_str};
	$self->{mes_str} = "";
}

sub print_clear {
	my ($self, $str) = @_;

	$self->{mes_str} = "";
}

sub warn {
	my ($self, $str) = @_;

	if($self->{warn} eq "on") {
		$self->{warn_happen} = 1;

		my $mes_str = $self->{mes_str};
		$mes_str = $mes_str."<p class='mes'><b>Warning:</b> ";
		$mes_str = $mes_str.$str;
		$self->{mes_str} = $mes_str."</p>\n";
	}
}

sub mes {
	my ($self, $str) = @_;

	my $mes_str = $self->{mes_str};
	$mes_str = $mes_str."<p class='mes'><b>Message:</b> ";
	$mes_str = $mes_str.$str;
	$self->{mes_str} = $mes_str."</p>\n";}

sub err {
	my ($self, $str) = @_;

	$self->{error_happen} = 1;
	$self->{gerr} = 1;

	my $mes_str = $self->{mes_str};
	$mes_str = $mes_str."<p class='mes'><b><font color='red'>Error:</font></b> ";
	$mes_str = $mes_str.$str;
	$self->{mes_str} = $mes_str."</p>\n";
}

sub code {
	my ($self, $str) = @_;

	my $mes_str = $self->{mes_str};
	$mes_str = $mes_str."<pre class='mes'>\n";
	$mes_str = $mes_str.$str;
	$self->{mes_str} = $mes_str."</pre>\n";
}

1;
