#!/usr/bin/perl -w

# Simple perl script demonstrating dynamically creating fill-out forms for
# QA testing, with output in EARL. (http://www.w3.org/2001/03/earl/)
# This script is licensed under the w3c software license available at 
# http://www.w3.org/Consortium/Legal/copyright-software-19980720
#
# This project is described at http://www.w3.org/QA/Tools/MUTAT
# Comments to www-qa@w3.org
#
# This was originally written by Nadia Heninger - nadia@barbwired.com
#
# Some more done on it by Charles McCathieNevile in 2005.

use CGI::Pretty;
use LWP::UserAgent;
use URI::Escape;
use lib ".";
use RDFtest;
use EARL;
use CGI::Carp qw(fatalsToBrowser);

# This stuff is all proxied from the W3C site
$ROOT = 'http://www.w3.org/QA/Tools/MUTAT';

###########################################
#
# A handful of different functions this script handles. They could probably be
# cleaned up into a switch or case or whatever PERL has to do cascading tests.

#
# If the page is called blank, ask for a test URI (makes an ugly page).
# This has actually been superseded by the page at http://www.w3.org/QA/Tools/bin/start
# although installing it means you need that page too. --cmn

$page = new CGI;
if (!$page->param()) {
  &demand_testurl ;
  exit 0;
}

# prints out the script's source
if ($page->param('script_print')) {
  open(SCRIPT, $page->url(-relative=>1));
  print $page->header('text/plain'), <SCRIPT>;
  close SCRIPT;
  exit 0;
}

# This tries to run a query for all the results that have been stored, and doesn't work.
# The error may be in the earl.w3.org server storing them, or not. --CMN

if ($page->param('algae')) {
 &algae_query;
 exit 0;
}


# Hard to know what this is meant to do for now, since it seems to refer to a subroutine that 
#  doesn't exist. So I have commented it out --CMN 050104
#
#if ($page->param('script_retrieve')) {
#  &query_database_page;
#  exit 0;
#}

# Make a new RDFtest from the parameter passed as TEST_url - this is some n3 like
# http://www.w3.org/QA/Tools/MUTAT/wcag.n3 --CMN

$test = RDFtest->new($page->param('TEST_url'));
if (!$test) {&html_die('Error with test page. Expected to have a parameter TEST_url');};

$frameset = $page->param('script_frameset');
$status = $page->param('script_status');

# This script serves lots of functions. The function performed depends on the values of the
#  control variables script_status and TEST_id
# TEST_id is the array index of the current question for the frames view
# script_frameset controls whether the script should be writing out the frameset page or the 
#  sub-frame containing the form to call itself again

if ($status == 3) {
# send the results to the Annotea database
  &post_to_database;
  exit 0;
} elsif (($status == 2) || $page->param('TEST_id') && ($page->param('TEST_id') > $test->size)) {
  $rdf_out = &create_output;
  #&pretty_output($rdf_out);
  &rdf_output($rdf_out);
} elsif ($status == 1) {
  &user_questions;
} elsif (!$frameset) {
  &create_testpage_noframes;
} else {
  &print_frameset if ($frameset =~ /top/) ;
  &print_frame_content if ($frameset =~ /sub/) ;
}

#
# This should e made to hand over the nice page at
#   http://www.w3.org/QA/Tools/MUTAT/bin/start --cmn
#

sub demand_testurl {
  print 
    $page->header('text/html'),
    $page->start_html(-title=>'test file submission',
		      -style=>{-src=>'http://www.w3.org/StyleSheets/base'}),
    $page->h3('please enter the URI of your test file'),
    $page->start_form(-action=>$page->url(-relative=>1)),
    $page->textfield(-name=>'TEST_url', -default=>"$ROOT/wcag.n3", -label=>'test location', -size=>"75"),
    $page->hidden('script_status','1'),
    $page->submit('submit'),
    $page->end_form,
    $page->end_html ;
}

# This needs major work. It should be collecting information required for the particular type of test.
# The assertor information should always be collected, since it is required by EARL. --CMN

sub user_questions {
  print 
    $page->header('text/html'),
    $page->start_html(-title=>'test parameters',
		      -style=>{-src=>'http://www.w3.org/StyleSheets/base'}),
    $page->h2('question and response time'),
    $page->start_form(-action=>$page->url(-relative=>1)),

# The assertor properties. These are always necessary, so should be pretty static

    $page->h3('assertor properties');
  print $page->start_table;
  print $page->Tr(
		  [
		   map {$page->td( [$test->{test}->get_property('rdf:Property', $_, 'rdfs:label'), 
				    $page->textfield($_ , $test->{test}->get_property('rdf:Property', $_, 'rdf:value'))])} 
		   $test->get_app_props('earl:Assertor')
		  ]
		 );
  print $page->end_table;

# The test properties - test subject properties that are fixed, plus whatever is requested in the test profile

  print $page->h3('testsubject properties');
  print $page->start_table;
  print $page->Tr(
		  [
		   $page->td(['test subject type:', $page->popup_menu('EARL_type', 
								      ['Tool', 'UserAgent', 'WebContent'],
								      ,'WebContent',
								      {'Tool'=>'tool', 'UserAgent'=>'user agent', 'WebContent'=>'web content'})]),
		   map {$page->td( [$test->{test}->get_property('rdf:Property', $_, 'rdfs:label'), 
				    $page->textfield($_ , $test->{test}->get_property('rdf:Property', $_, 'rdf:value'))])} 
		   $test->get_app_props('earl:TestSubject')
		  ]
		 );
  print $page->end_table;

# If the test set has been divided into groups, allow the user to choose which ones to select

  print $page->h3('use tests from the following groups:') if (@groups = $test->get_groups);
  foreach (@groups) {
    my @unique = $test->get_unique($_);
    print $page->b($test->{test}->get_property('td:GroupProperty', $_, 'rdfs:label')),
    $page->br,
    $page->checkbox_group(-name=>$_,
			  -values=>[@unique],
			  -default=>[@unique],
			 -linebreak=>'true'),
    $page->br;
  }
  $page->param('script_status', 0);
  &copy_state_info;
  print
    $page->checkbox(-name=>'script_frameset',
		    -value=>'top',
		    -label=>'use frames version'),
    ' (for tests designed to render html)',
    $page->br,
    $page->submit('submit'),
    $page->end_form,
    $page->end_html ;
}

# prints the outer frameset with the appropriate page displayed in the upper frame, then
# calls itself again (the self_url preserves state info) to create the submit form
sub print_frameset {
  my $TEST_id = ($page->param('TEST_id') or $test->increment_test(-1, $page->param('test_groups')));
  $page->param('TEST_id', $TEST_id);
  $test_url = $test->get($TEST_id, 'earl:id');
  $page->param('script_frameset', 'sub');
  $submit_url=$page->url(-relative=>1,-query=>1);
  print $page->header;
    print <<DONE;
<html><head><title>Test Page</title></head>
<frameset rows="80,20">
<frame src="$test_url" name="test">
<frame src="$submit_url" name="submit">
</frameset>
</html>
DONE
  exit 0;
}

# creates the lower frame for the frames view, and updates state info
sub print_frame_content {
  my $TEST_id = $page->param('TEST_id');
  $page->param('script_frameset','top');

  print
    $page->header('text/html'),
    $page->start_html(-style=>{ -src=>'http://www.w3.org/StyleSheets/base',
				-code=>'form > h2 + p { display: inline; } form { text-align: center; }'
			      }),
    $page->start_form(-target=>"_top", -action=>$page->url(-relative=>1)),
    &make_test_stuff($TEST_id),
    &make_test_button($test->get($TEST_id));
  
  map {$groups{$_} = [$page->param($_)];} $test->get_groups;
  
  $page->param('TEST_id', $test->increment_test($TEST_id, %groups));
  &copy_state_info;

# make the progress count displayed start from 1 instead of zero - CMN

    my $progress = '[';
       $progress .= $TEST_id + 1 ;
       $progress .= ' of ' ;
       $progress .= $test->size + 1 ;
       $progress .= ']';

  print 
    $page->br,
    $page->submit(-name=>'submit', -value=>"[ Next test ]"),
    $page->p($progress),
    $page->end_form;
  print
    $page->start_form(-target=>"_top", -action=>$page->url(-relative=>1));
    $page->param('script_status', 2);
    &copy_state_info;
  print
    $page->submit(-name=>'submit', -value=>'create report now'),
    $page->end_form,
    $page->end_html;
}


# test results are stored by their id as plain old form variables
sub make_test_button {

  my ($vals, $labels) = $test->get_result_properties;
  return map {$page->span('<label>'.$_.'</label>')} ($page->popup_menu(-name=>$_[0],
			     -values=>$vals,
			     -labels=>$labels,
			     -default=>'Not tested'),
		       'comment:'.$page->textfield(-size=>'50', $_[0].'_comment'));
}

sub make_test_stuff {
  my ($TEST_id) = @_;
  my @out = ();
  push @out, $page->h2($test->get($TEST_id, 'rdfs:label'));

# Change this next so that framesets take advantage of being in frames. One day. CMN

  push @out, $page->a({href=>$test->get($TEST_id, 'earl:id')}, '[test]') unless ($frameset);
 
  foreach ($test->get_disp_props('earl:TestCase')) {
    my $val = $test->get($TEST_id, $_);
    next unless $val;
    push @out, $page->start_div;
    if ($test->{test}->get_property('td:DisplayedProperty', $_, 'rdfs:range') eq $test->{test}->expand('rdfs:Resource')) {
      push @out, $page->a({href=>$val}, $test->{test}->get_property('td:DisplayedProperty', $_, 'rdfs:label'));
# Should also have the rdfs:comment here? think about it -CMN
    } else {
      push @out, $val;
    }
    push @out, $page->end_div;
  }
  return @out;
}

# prints out all the variables submitted to the current incarnation of the script as hidden
# form elements so they can be passed on
sub copy_state_info {
  foreach $var_inc ($page->param) {
    print $page->hidden($var_inc, $page->param($var_inc)), "\n" unless ($var_inc =~ /submit/i);
  }
}

#
# Make a page that includes all the tests so people can just run through them.
#

sub create_testpage_noframes {
  $page->param('script_status','2');
  print
    $page->header('text/html'),
    $page->start_html(-title=>'test page',
		       -style=>{-src=>['http://www.w3.org/StyleSheets/base', "$ROOT/simple.css", "$ROOT/tabular.css"]}),
    $page->start_form(-action=>$page->url(-relative=>1));
  &copy_state_info;

  print
    $page->h1('test questions');

  map {$groups{$_} = [$page->param($_)];} $test->get_groups;
  my $TEST_id = -1;
  while (($TEST_id = $test->increment_test($TEST_id, %groups)) <= $test->size) {
    print $page->start_div;

# Should the make_test_button be moved to be called inside make_test_stuff? -CMN

    print &make_test_stuff($TEST_id, 'earl:id'),
    $page->div(&make_test_button($test->get($TEST_id)));
    print $page->end_div;
  }
  print
    $page->submit('submit'),
    $page->end_form,
    $page->end_html;
}

# produce pretty EARL... 

#
# There needs to be a bunch of work on this to update it...
# It should also offer the choice of an EARL report or an HTML human-readable report.
#
# At the point where we can read in existing EARL, this will become useful for building tables 
#  to compare results. Insha'allah...

sub create_output {

  $earl = EARL->new($test->{test});
  my $assertor_uri = $test->{test}{ns}{'td'} . 'Assertor' . time;
  my $testsubject_uri = $test->{test}{ns}{'td'} . 'TestSubject' . time;
  
  my %props = ();
  map {$props{$_} = $page->param($_) if $page->param($_);} $test->get_app_props('earl:Assertor');
  $earl->create_assertor($assertor_uri, %props);
    
  %props = ();
  map {$props{$_} = $page->param($_) if $page->param($_);} $test->get_app_props('earl:TestSubject');
  $earl->create_tool($page->param('EARL_type'), $testsubject_uri, %props);

  for (my $i = 0; $i <= $test->size; $i++) {
    my $result = $page->param($test->get($i));
    next unless $result;
    $earl->add_assertion('earl:assertedBy'=>$assertor_uri,
			 'earl:regarding'=>$testsubject_uri,
			 'earl:result'=>$result, 
			 'earl:tested'=>$test->get($i),
			 'rdfs:comment'=>$page->param($test->get($i) . '_comment'));
    $earl->add_description($test->get($i), $test->get_testcase($i));
  }

  
  return $earl->out;
}

# make pretty output in case text rdf tags don't show up
# netscape linux apparently hasn't implemented <pre> properly, so it'll show up as mush
sub pretty_output {  
  my $preStyle=<<DONE;
pre {
  margin-left: 2em;
  margin-right: 2em;
 color: black;
 border:thin dotted;
 padding: 0.5em}
DONE
  $page->param('script_status', '3');
  print 
    $page->header('text/html'),
    $page->start_html(-title=>'test results',
		      -style=>{-src=>'http://www.w3.org/StyleSheets/base',
			       -code=>$preStyle}
		     ),
  $page->h3('EARL output'),
  $page->start_form,
  $page->submit('Post to database');
  &copy_state_info,
  print
    $page->end_form,
    $page->start_pre,
    $page->escapeHTML($_[0]),
    $page->end_pre,
    $page->end_html;
}

sub rdf_output {
 $_[0] =~ s/></>\n</g;
  print $page->header('text/plain'),
 $_[0];
}

#
# Put the results into iggy's annotations database (sometimes known as earl.w3.org?)
# iggy works, earl.w3.org doesn't - internal error :-(
#
sub post_to_database {
  $ua = LWP::UserAgent->new;
  $h = new HTTP::Headers;
  $h->authorization_basic('mutantUser', 'mutantUser');
  $h->push_header(Accept => 'application/xml');

  my $request = HTTP::Request->new(POST, 'http://iggy.w3.org/annotations', $h, &create_output);
  $request->content_type('application/xml');

  my $response = $ua->request($request);
  print 
    $page->header($response->content_type), 
    "\n\n", 
    $response->content;
}

#
# Return a query from the annotea database. Not sure why there are two versions, but will make one 
# of them look for old stuff, the other new stuff. (Should eventually look for both, and transform
# the output all to new namespace. Or just do a transform once on everything and post it back?)
#

sub algae_query {
	$ua = LWP::UserAgent->new;
$content = '';
$content2 = '';
$earlns = 'http://www.w3.org/2001/03/earl/0.95#';
$rdfns = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
$content .= <<DONE ;
(ask
     '((http://www.w3.org/1999/02/22-rdf-syntax-ns#subject ?a ?ts)
(http://www.w3.org/2001/03/earl/0.95#testSubject ?ts ?page)
(http://www.w3.org/2001/03/earl/0.95#date ?ts ?date)
(http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate ?a ?tp)
(http://www.w3.org/1999/02/22-rdf-syntax-ns#object ?a ?tc)
) :collect '(?page ?date ?tp ?tc))
DONE

$content2 .= <<DONE ;
(ask
 '(
(${earlns}asserts ?a ?assertion)
(${rdfns}predicate ?assertion ?state)
(${rdfns}subject ?assertion ?subject)
(${rdfns}object ?assertion ?object)
(http://www.w3.org/1999/02/22-rdf-syntax-ns#type ?a http://www.w3.org/2001/03/earl/0.95#Person)
(http://www.w3.org/2001/03/earl/0.95#name ?a ?name)
) :collect '(?subject ?state ?object ?name ?assertion))
DONE

$content = 'w3c_algaeQuery=' . &uri_escape($content);
$content2 = 'w3c_algaeQuery=' . &uri_escape($content2);

	$h = new HTTP::Headers;
#
# Get this out of here - see how to use W3C properties stuff!!!
#
	$h->authorization_basic('mutantUser', 'mutantUser');

	$h->push_header(Accept => 'application/xml');

	my $request = HTTP::Request->new(POST => 'http://earl.w3.org/earl', $h, $content2);	
	my $response = $ua->request($request);

	print 
		$page->header('text/plain'),
	    	$response->content;
 }

sub html_die {
  print
    $page->header('text/html'),
    $page->start_html(-title=>'cgi error',
		      -style=>{'src'=>'http://www.w3.org/StyleSheets/Core/Steely'}),
    $_[0],
    $page->end_html ;
  exit 0;
}