#!/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
# Comments to nadia@barbwired.com

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

$ROOT = 'http://www.w3.org/QA/Tools/MUTAT';

$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;
}

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

if ($page->param('script_retrieve')) {
  &query_database_page;
  exit 0;
}

$test = RDFtest->new($page->param('TEST_url'));
if (!$test) {&html_die('error with test page');};

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

# script serves lots of functions... switches on 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) {
  &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/) ;
}

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 test file'),
    $page->start_form,
    $page->textfield(-name=>'TEST_url', -default=>"$ROOT/wcag.n3", -label=>'test location'),
    $page->hidden('script_status','1'),
    $page->submit('submit'),
    $page->end_form,
    $page->end_html ;
}


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,
    $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;
  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;

  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->self_url;
  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"),
    &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;

  print 
    $page->br,
    $page->submit(-name=>'submit', -value=>"[$TEST_id of " . $test->size . "]"),
    $page->end_form;
  print
    $page->start_form(-target=>"_top");
    $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->radio_group(-name=>$_[0],
			     -values=>$vals,
			     -labels=>$labels,
			     -default=>' '),
		       'comment:'.$page->textfield($_[0].'_comment'));
}

sub make_test_stuff {
  my ($TEST_id) = @_;
  my @out = ();
  push @out, $page->h2($test->get($TEST_id, 'rdfs:label'));
  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'));
    } 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);
  }
}

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;
    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... 
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];
}

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;
}

sub algae_query {
	$ua = LWP::UserAgent->new;
$content = '';
$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;
	  $h->authorization_basic('mutantUser', 'mutantUser');
	$h->push_header(Accept => 'application/xml');

	my $request = HTTP::Request->new(POST => 'http://iggy.w3.org/annotations', $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;
}