package WWW::Meta::XML::Browser;

use strict;
use warnings;

=head1 NAME

WWW::Meta::XML::Browser - Perl module to simulate a browser session described in a XML file

=head1 SYNOPSIS

  use WWW::Meta::XML::Browser;

  my $session = WWW::Meta::XML::Browser->new();
  $session->process_file('file.xml');
  $session->process_all_request_nodes();
  $session->print_all_request_results();

=head1 ABSTRACT

This module reads a XML file from a given source and makes the HTTP-requests defined in this XML file.
The result of such a request can be filtered using a XSL stylesheet.
The following requests can be build using results from the transformation.

=head1 DESCRIPTION

=head2 WRITING A SESSION DESCRIPTION FILE

The most important part when working with C<WWW::Meta::XML::Browser> is to write a session description file. Such a file describes which http requests are made and how the results of the requests are handled.

The session description file is a simple XML file. The root element is E<lt>meta-sessionE<gt> and so the DTD is to be found at L<http://www.boksa.de/pub/xml/dtd/meta-session.dtd>, which leads us to the following construct:

  <?xml version="1.0" ?>
  <!DOCTYPE meta-session SYSTEM "http://www.boksa.de/pub/xml/dtd/meta-session.dtd">
  <meta-session>
  <!-- ... -->
  </meta-session>

Under the root element we will add some elements for the requests we want to make. A very complete request will look like the following:

  <request url="http://www.google.de/" method="get" stylesheet="google-index.xsl">
  </request>

The only attribute of the request-element that is required is url, all other attributes can be left out. If method is left out the default method get will be used. If stylesheet is left out, the raw html will be transformed to a valid XML document which will than be stored as the result of that request.

The request-element has an optional child element, which can be used to specify the content of a request. The element is called content and is used as a child of the request element as follows (remember that & has to be written as &amp; in XML):

  <request url="http://www.google.de/search" method="get">
    <content>q=42&amp;ie=ISO-8859-1&amp;hl=de&amp;meta=</content>
  </request>

This example shows that the content will be sent using the specified method (get in this case) to the url of the request (http://www.google.de/search).

A session description file must contain at least on request.

=head3 REPLACEMENT EXPRESSIONS IN A SESSION DESCRIPTION FILE

There are some cases in which static urls and a static content don't fit the requirements of what has to be done.

For this case WWW::Meta::XML::Browser has an easy way to use arguments passed to the instance during creation or values from a previous result.

To access arguments passed to the instance during creation the following simple syntax is used:

  #{args:key}

The word key has to be replaced with the key of the hash containing the arguments. This will lead to the replacement of C<#{args:key}> with the appropriate value from the hash.

Accessing previous results basically goes the same way, some example show, that it even offers more possibilities:

  #{0:0:/foo}
  #{4:1-3:/foo/too}
  #{1::/foo/@argument}
  #escape{0:0:/foo}
  #escape{4:1-3:/foo/too}
  #escape{1::/foo/@argument}

The first three example and the last three examples have only one difference, which is the word escape. This command simply tells the module to url-escape the value that is returned by that later part of the expression.

Let's look at these expressions in detail:

The first part (the number before the first colon) specifies the index (starting with 0) of the request which we want to access. This index can be mapped directly to the session description file.

The second part (between the first and the second colon) specifies the subrequest results (more about subrequests later) that will be looked at. 0 in the first example specifies the first subrequest. 1-3 in the second example specifies the subrequests 2,3 and 4 (remember, we begin indexing with 0). The third example accesses all subrequests.

The last part (after the second colon) specifies an XPath-Expression, which is looked up in each of the subrequest results and a list of all values which match the Expression is generated.

This list is taken and each value of the list will replace the whole replacement expression, and for each replacement one http request is made.

Naturally if the url or the content contains more than one replacement expression all possible combinations are requested (which actually is the product of the different numbers of matching XPath-Expressions).

These different http requests make up the subrequests which are stored and can be accessed, when needed. Please not that subrequests can be merged into a singele subrequest result using L<merge_subrequests()>.

=head2 CREATING A NEW BROWSER OBJECT

To create a new browser object the L<new()>-method is called, with an optional hash containing options.

  $browser = WWW::Meta::XML::Browser->new(%options);

The following options are possible:

  args => \%args

C<\%args> is the pointer to a hash which values can be accessed from the session description file by their keys. The syntax to access the hash values from the session file is C<#{args:key}>, where key is a key from the hash.

  debug => 1

When the debug option is set, the module produces a lot of debug output about execution times.

  debug_callback => \&debug

C<\&debug> has to be a pointer to a subroutine taking two parameters. The first parameter is a number >= 0 which describes the logging level. The second parameter is the string which is the message to be printed.
Please note that there is a default routine L<_debug()>.

  result_callback => \&result

C<\&result> has to be a pointer to a subroutine taking one parameter. The parameter is an instance of C<XML::LibXML::Document> and can be manipulated. The subroutine must return an instance of C<XML::LibXML::Document>.
Please note that there is a default routine L<_result()>.

=head2 PROCESSING A SESSION DESCRIPTION FILE

To read the session description file one of the following methods is called, depending on the source of the file.

  $browser->process_file($file);
                 -or-
  $browser->process_url($url);
                 -or-
  $browser->process_string($string);
                 -or-
  $browser->process_xml_doc($doc);

The names of the methods should be self-explaining:

L<process_file()> is called when the session description file is on a local disk an read by the script directly (this should be the most common case).

L<process_url()> is called when the session description file is accessed by an http request.

L<process_string()> is called when the session description data is available in a scalar variable.

L<process_xml_doc()> is called when the XML document has already been parsed (as done by the three methods above and we have a instance of XML::LibXML::Document.

=head2 PROCESSING THE REQUESTS FROM THE SESSION DESCRIPTION FILE

After the session description file has been processed as shown above, the request nodes contained in the XML document can be processed.

  $browser->process_all_request_nodes();
                   -or-
  while (my $r_node = $browser->get_next_request_node()) {
    $browser->process_request_node($r_node);
  }

L<process_all_request_nodes()> encapsulates the second construction with the while loop.
Both constructions execute all http requests generated from the session description file and store the results of the (optionally transformed) requests.

=head2 ACCESSING THE RESULTS

The result of a spceific request can be accessed with a simple call which returns an instance of C<XML::LibXML::Document>.

  $result = $browser->get_request_result($request_index, $subrequest_index);

To access the results one has to understand how results are stored. The results are stored in a two-dimensional array.

The first index (which starts with 0 for the first request) describes the request which can be found in the session description file.

The second index describes the real index after all permutations caused by possible replacements in the url or content have been generated.

For example C<$browser-E<gt>get_request_result(0, 2)> returns the result of the third request generated from the first request node in the session description file.

=head1 EXPORT

None by default.

=cut

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use WWW::Meta::XML::Browser ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);

our $VERSION = '0.03';

use HTTP::Cookies;
use HTTP::Request;
use LWP::UserAgent;
use Time::HiRes;
use URI::Escape;
use XML::LibXML;
use XML::LibXSLT;



my $REQUEST_XPATH			= '/meta-session/request';
my $AUTHORIZATION_XPATH		= './authorization';
my $CONTENT_XPATH			= './content';

my $XPATH_REGEXP			= '\#(escape)*\{(\d+?):(.*?):(.+?)\}';
my $ARGS_REGEXP				= '\#(escape)*\{args:(.*?)\}';

my $URL_ATTRIBUTE			= 'url';
my $METHOD_ATTRIBUTE		= 'method';
my $STYLESHEET_ATTRIBUTE	= 'stylesheet';

my $XML_VERSION				= '1.0';

=head1 METHODS

The following methods are available:

=over 4

=cut



=item $browser = WWW::Meta::XML::Browser->new(%options);

This class method contructs a new C<WWW::Meta::XML::Browser> object and returns a reference to it.

The hash C<%options> can be used to control the behaviour of the module and to provide some data to it as well. At the moment the following Key/Value pairs are supported:

  KEY:                VALUE:       DESCRIPTION:
  ---------------     --------     -------------
  args	              \%args       a pointer to a hash of arguments which can be used in
                                   requests
  debug               0/1          a boolean true or boolean false value can be passed to
                                   the module to control weather debugging information are
                                   printed or not
  debug_callback      \&debug      a pointer to a debug-callback
  result_callback     \&result     a pointer to a result-callback

=cut

sub new {
	my $type = shift;
	my (%cnf) = @_;
	
	my $this = {};
	
	bless $this, $type;

	$this->{debug_callback} = \&_debug;
	$this->{result_callback} = \&_result;
	
	$this->{args} = $cnf{'args'} if $cnf{'args'};		
	$this->{debug} = 1 if $cnf{'debug'};
	$this->{debug_callback} = $cnf{'debug_callback'} if $cnf{'debug_callback'};
	$this->{result_callback} = $cnf{'result_callback'} if $cnf{'result_callback'};

	$this->{request_nodes} = ();

	$this->{request_results} = ();

	$this->{ua} = LWP::UserAgent->new(cookie_jar => HTTP::Cookies->new());
	&{$this->{debug_callback}}(0, "LWP::UserAgent created") if $this->{debug};

	$this->{xml_parser} = XML::LibXML->new();
	$this->{xml_parser}->validation(1);
	$this->{xml_parser}->load_ext_dtd(1);
	&{$this->{debug_callback}}(0, "XML::LibXML-Parser created") if $this->{debug};
		
	return $this;
}



=item process_url($url);

Reads the XML file containing session description from the specified url and constructs a XML document from it which is then passed to L<process_xml_doc()>.

=cut

sub process_url {
	my $this = shift;
	my ($url) = @_;

	&{$this->{debug_callback}}(0, "process_url() called") if $this->{debug};
	my $source = LWP::UserAgent::get($url);
	&{$this->{debug_callback}}(1, "LWP::UserAgent::get($url) succeeded") if $this->{debug};

	my $doc = $this->{xml_parser}->parse_html_string($source);
	&{$this->{debug_callback}}(1, "parse_html_string() succeeded") if $this->{debug};

	$this->process_xml_doc($doc);
}



=item process_file($file);

Reads the XML file containing session description and constructs a XML document from it which is then passed to L<process_xml_doc()>.

=cut

sub process_file {
	my $this = shift;
	my ($file) = @_;

	&{$this->{debug_callback}}(0, "process_file() called") if $this->{debug};
	my $doc = $this->{xml_parser}->parse_file($file);
	&{$this->{debug_callback}}(1, "parse_file($file) succeeded") if $this->{debug};
	
	$this->process_xml_doc($doc);
}



=item process_string($string);

Constructs a XML document from the given string which is then passed to L<process_xml_doc()>.

=cut

sub process_string {
	my $this = shift;
	my ($string) = @_;
	
	&{$this->{debug_callback}}(0, "process_string() called") if $this->{debug};
	my $doc = $this->{xml_parser}->parse_string($string);

	$this->process_xml_doc($doc);
}



=item process_xml_doc($doc);

Takes the given XML ocument and reads the request-nodes in the XML file. These request nodes are stored internally to be processed.

=cut

sub process_xml_doc {
	my $this = shift;
	my ($doc) = @_;

	&{$this->{debug_callback}}(0, "process_xml_doc() called") if $this->{debug};
	my $r_nodeset = $doc->findnodes($REQUEST_XPATH);

	foreach my $r_node ($r_nodeset->get_nodelist()) {	
		push(@{$this->{request_nodes}}, $r_node);	
	}

	&{$this->{debug_callback}}(1, ($#{$this->{request_nodes}} + 1)." request nodes read") if $this->{debug};	
}



=item $node = get_next_request_node();

Returns the next request-node which than can be processed using L<process_request_node()>

=cut

sub get_next_request_node {
	my $this = shift;

	return shift(@{$this->{request_nodes}});
}



=item process_all_request_nodes();

Iterates over all request nodes and processes each of them.

=cut

sub process_all_request_nodes {
	my $this = shift;

	while (my $r_node = $this->get_next_request_node()) {
		$this->process_request_node($r_node);
	}
}



=item process_request_node($r_node);

Processes the request node. This subroutine does the actual work:
It generates all permutations of the url
It genarates all permutations of the content
It generates all permutations ot the url and the content
It makes the requests and processes the results
it stores the (optionally transformed) results

=cut

sub process_request_node {
	my $this = shift;
	my ($r_node) = @_;

	&{$this->{debug_callback}}(0, "process_request_node() called") if $this->{debug};
	&{$this->{debug_callback}}(1, "processing url: ".$r_node->getAttribute($URL_ATTRIBUTE)) if $this->{debug};

	my @processed_url = ();	
	$this->parse_string($r_node->getAttribute($URL_ATTRIBUTE), \@processed_url);	

	if ($this->{debug}) {
		foreach my $url (@processed_url) {
			&{$this->{debug_callback}}(2, "expanded url: ".$url) if $this->{debug};
		}
	}

	
	# process the content specified for the request
	my $c_nodeset = $r_node->findnodes($CONTENT_XPATH);

	&{$this->{debug_callback}}(1, "processing content") if $this->{debug};

	my @processed_content = $this->process_content_nodeset($c_nodeset);

	if ($this->{debug}) {
		foreach my $content (@processed_content) {
			&{$this->{debug_callback}}(2, "expanded content: ".$content) if $this->{debug};
		}
	}


	my @subrequest_result = ();

	foreach my $url (@processed_url) {

		foreach my $content (@processed_content) {
			my ($res, $doc);
			
			$res = $this->make_request($url, $r_node->getAttribute($METHOD_ATTRIBUTE), $content);		

			if ($res) {	
				$doc = $this->process_result($res, $r_node->getAttribute($STYLESHEET_ATTRIBUTE));
			}
			
			if ($doc) {
				push(@subrequest_result, $doc);
			}
		}

	}

	push(@{$this->{request_results}}, \@subrequest_result);
}



=item @processed_content = process_content_nodeset($c_nodeset);

Processes a content nodeset and generates all possible permutations by replacing the tokens.

=cut

sub process_content_nodeset {
	my $this = shift;

	my ($c_nodeset) = @_;

	my @content;
		
	foreach my $c_node ($c_nodeset->get_nodelist()) {
		my @raw_content = split(/&/, $c_node->string_value());
		
		foreach my $pair (@raw_content) {
			my ($name, $value);
				
			if ($pair =~ /=/) {		
				($name, $value) = split(/=/, $pair);
				
				if (($value !~ /$XPATH_REGEXP/) && ($value !~ /$ARGS_REGEXP/)) {
					$value = uri_escape($value);
				}
				
				push(@content, $name.'='.$value);
			}
			else {
				if (($pair !~ /$XPATH_REGEXP/) && ($pair !~ /$ARGS_REGEXP/)) {
					$value = uri_escape($pair);
				}
				else {
					$value = $pair;
				}
												
				push(@content, $value);
			}
		}
	}
	
	my $content = join('&', @content);
		
	my @processed_content = ();
	$this->parse_string($content, \@processed_content);

	return @processed_content;
}



=item make_request($url, $method, $content);

Makes a request to C<$url> sending the C<$content> using C<$method> and returns the result.

=cut

sub make_request {
	my $this = shift;
	my ($url, $method, $content) = @_;

	&{$this->{debug_callback}}(1, "make_request() called") if $this->{debug};
	&{$this->{debug_callback}}(2, "url:     ".$url) if $this->{debug};
	&{$this->{debug_callback}}(2, "content: ".$content) if $this->{debug};
	&{$this->{debug_callback}}(2, "method:  ".$method) if $this->{debug};

	my $t0 = [Time::HiRes::gettimeofday()] if $this->{debug};
	
	my $req;

	if ($method =~ /get/i) {
		$req = HTTP::Request->new('GET' => $url.'?'.$content);
	}
	elsif  ($method =~ /post/i) {
		$req = HTTP::Request->new('POST' => $url);
		$req->content_type('application/x-www-form-urlencoded');
		$req->content($content);
	}
	
	my $res = $this->{ua}->request($req);
	
	&{$this->{debug_callback}}(2, "time:    ".Time::HiRes::tv_interval($t0)) if $this->{debug};

	if ($res->is_success()) {
		return $res;
	}
	elsif ($res->is_redirect()) {
		warn "Redirect (".$res->code().") to \"".$res->headers->header('Location')."\"\n";
#		return $this->make_request($res->headers->header('Location'), 'get', '');
	}
	else {
		warn "Error (".$res->code().") while processing request result from ".$method."-request to ".$url." with content ".$content."\n";
		return 0;
	}
}



=item $doc = process_result($res, $stylesheet);

Processes the result (C<$res>) as returned by L<make_request()> by transforming it into a XML document.
If a XSL-Stylesheet (C<$stylesheet>) has been specified for the given request the XML document will be transformed using that stylesheet.
The resulting XML document is then returned.

=cut

sub process_result {
	my $this = shift;	
	my ($res, $stylesheet) = @_;

	&{$this->{debug_callback}}(1, "process_result() called") if $this->{debug};
		
	# the result doc is undef by default and will not change if the request was not successfull
	my $doc = undef;

	my $t0 = [Time::HiRes::gettimeofday()] if $this->{debug};

	# create a parser for the result
	my $parser = XML::LibXML->new();

	# parse the html and generate the result doc
	$doc = $parser->parse_html_string($res->content());

	&{$this->{debug_callback}}(2, "time to parse html:       ".Time::HiRes::tv_interval($t0)) if $this->{debug};

	# if a stylesheet has been specified use it to transform the result doc
	if ($stylesheet) {
		my $t0 = [Time::HiRes::gettimeofday()] if $this->{debug};

		my $style_doc = $parser->parse_file($stylesheet);

		my $xslt = XML::LibXSLT->new();
		my $stylesheet = $xslt->parse_stylesheet($style_doc);

		# overwrite the old result doc with the new result doc
		$doc = $stylesheet->transform($doc);	

		&{$this->{debug_callback}}(2, "time to transform result: ".Time::HiRes::tv_interval($t0)) if $this->{debug};
	}
	
	return &{$this->{result_callback}}($doc);	
}



=item $result = get_request_result($request_index, $subrequest_index);

Returns the request-result specified by C<$request_index> and C<$subrequest_index>.

=cut

sub get_request_result {
	my $this = shift;
	my ($request_index, $subrequest_index) = @_;

	return ${$this->{request_results}}[$request_index][$subrequest_index];
}



=item print_all_request_results();

Iterates over all the request results and prints them.

=cut

sub print_all_request_results {
	my $this = shift;

	my @requests = @{$this->{request_results}};
	my $r = 0;

	foreach my $request (@requests) {		
		my @subrequests = @{$request};

		print "-------------------- REQUEST (".($r++ + 1)."/".($#requests + 1).") --------------------\n";

		my $s = 0;
	
		foreach (@subrequests) {
			print "-------------------- SUBREQUEST (".($s++ + 1)."/".($#subrequests + 1).")--------------------\n";
			$this->print_request_result($_);
		}
	}
}



=item print_request_result($result);

Prints the specified request result.

=cut

sub print_request_result {
	my $this = shift;
	my ($doc) = @_;
	
	print $doc->toString();
}



=item merge_subrequests($request_index, $wrapper_name);

Merges the subrequest of the request (specified by C<$request_index>) in a new XML document which consists of a new root element (C<$wrapper_name>) and all the subrequests as childs of this root element.

=cut

sub merge_subrequests {
	my $this = shift;
	my ($request_index, $wrapper_name) = @_;

	my $root = XML::LibXML::Element->new($wrapper_name);

	my @subrequests = @{$this->{request_results}->[$request_index]};
	
	foreach my $subrequest (@subrequests) {
		$root->appendChild($subrequest->documentElement());
	}

	my $doc = XML::LibXML->createDocument($XML_VERSION);
	$doc->setDocumentElement($root);

	my @doc = ($doc);
	$this->{request_results}->[$request_index] = \@doc;
}



=item parse_string($s, $r);

Recursively parses the string passed as C<$s> and writes the replacement results to C<@{$r}>, which will be an array containing all possible permutations, created by the replacement of the specified tokens.

=cut

sub parse_string {
	my $this = shift;
	my ($s, $r) = @_;

	if ($s =~ /(.*?)$XPATH_REGEXP(.*)/) {
		my $pre = $1;
		my $escape = $2;
		my $request_index = $3;
		my $subrequest_index = $4;
		my $xpath = $5;
		my $post = $6;

		my @subrequests = @{$this->{request_results}->[$request_index]};
				
		my @xml_docs = ();

		if ($subrequest_index =~ /^(\d*)-(\d*)$/) {
			my $start = $1;
			my $end = $2;
			
			if (!$start) {
				$start = 0;
			}
			if (!$end) {
				$end = $#subrequests;
			}
			
			for (my $i = $start; $i <= $end; $i++) {
				push(@xml_docs, $subrequests[$i]);
			}
		}
		elsif ($subrequest_index =~ /^(\d+)$/) {		
			my $index = $1;
			
			push(@xml_docs, $subrequests[$index]);
		}
		else {
			my $start = 0;
			my $end = $#subrequests;

			for (my $i = $start; $i <= $end; $i++) {
				push(@xml_docs, $subrequests[$i]);
			}			
		}

		foreach my $xml_doc (@xml_docs) {
			my $nodeset = $xml_doc->findnodes($xpath);
		
			my $i = 0;
		
			my @return = ();
		
			foreach my $node ($nodeset->get_nodelist()) {
				my $value = $node->string_value();
				
				if ($escape) {
					$value =~ s/[\s]*(.*?)[\s]*/uri_escape($1)/egs;
				}
				else {
					$value =~ s/[\s]*(.*?)[\s]*/$1/egs;
				}
				
				$this->parse_string($pre.$value.$post, $r, $escape);	
			}
		}
	}
	elsif ($s =~ /(.*?)$ARGS_REGEXP(.*)/) {
		my $pre = $1;
		my $escape = $2;
		my $arg = $3;
		my $post = $4;

		if ($escape) {
			$this->parse_string($pre.uri_escape($this->{args}->{$arg}).$post, $r, $escape);
		}
		else {
			$this->parse_string($pre.$this->{args}->{$arg}.$post, $r, $escape);
		}		
	}
	else {
		push(@{$r}, $s);
	}		
}



=item _debug($l, $msg);

Default debug-callback. Prints C<$msg> as a debugging message. C<$l> gives information about the logging level. 

=cut

sub _debug {
	my ($l, $msg) = @_;	

	print "   " x $l;
	print "DEBUG: ".$msg."\n";
}



=item $doc = _result($doc);

Default result-callback. Just returns C<$doc> as it was passed to the subroutine.

=cut

sub _result {
	my ($doc) = @_;	

	return $doc;
}



# Preloaded methods go here.

1;
__END__

=back

=head1 SEE ALSO

The DTD for the session description files can be found at:
  L<http://www.boksa.de/pub/xml/dtd/meta-session.dtd>

Documentation and a HOWTO can be found at:
  L<http://www.boksa.de/perl/modules/www-meta-xml-browser/>

=head1 AUTHOR

Benjamin Boksa, E<lt>benjamin@boksa.deE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Benjamin Boksa

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut