Test::Litmus - Perl module to submit test results to the Litmus testcase

  use Test::Litmus;

  $t = Test::Litmus->new(-machinename => 'mycomputer',
  						 -username => 'user', 
  						 -authtoken => 'token',
  			# optional # -server => 'http://litmus.mozilla.org/process_test.cgi', 
  			# optional # -action => 'submit');

  $t->sysconfig(-product => 'Firefox',
  				-platform => 'Windows', 
  				-opsys => 'Windows XP', 
  				-branch => 'Trunk', 
  				-buildid => '2006061314',
  				-buildtype => 'debug cvs',
  				-locale => 'en-US');

  my $result = Test::Litmus::Result->new(
  							-isAutomatedResult => 1, # optional
  							-testid => 27,
  							-resultstatus => 'pass', # valid results are 'pass'
  													 # or 'fail'
  							-exitstatus => 0,
  							-duration => 666,
  							-timestamp => 20051111150944, # optional (default: current time)
  							-comment => 'optional comment here', # optional
  							-bugnumber => 300010, 				 # optional
  							-log => [Test::Litmus::Log->new(	 # optional
  										-type => 'STDOUT',
  										-data => 'foobar'),
  									 Test::Litmus::Log->new(
  									 	-type => 'Extensions Installed',
  									 	-data => 'log information here')]
  							);
  $t->addResult($result);
  # $t->addResult($someOtherResult);
  # etc...

  # add log information that should be linked with 
  # all results (i.e. env variables, config info)
  $t->addLog(Test::Litmus::Log->new(
  								-type => 'STDOUT',
  								-data => 'log data')); 

  my $res = $t->submit();

  # $res is 0 for non-fatal errors (some results were submitted), and 
  # undef for fatal errors (no results were submitted successfully)

  if ($t->errstr()) { die $t->errstr() }

# The contents of this file are subject to the Mozilla Public License Version 
# 1.1 (the "License"); you may not use this file except in compliance with 
# the License. You may obtain a copy of the License at 
# http://www.mozilla.org/MPL/
# 
# Software distributed under the License is distributed on an "AS IS" basis,
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
# for the specific language governing rights and limitations under the
# License.
# 
# The Original Code is Test::Litmus.
# 
# The Initial Developer of the Original Code is The Mozilla Corporation.
# 
# Portions created by the Initial Developer are Copyright (C) 2006
# the Initial Developer. All Rights Reserved.
# 
# Contributor(s): Zach Lipton <zach@zachlipton.com>

# import these into the main namespace so our users don't have to explicitly 
# use them as well...
BEGIN {
	package main;
	use Test::Litmus::Log;
	use Test::Litmus::Result;
}

package Test::Litmus;

use v5.6.1;
use strict;

use HTTP::Request::Common qw(POST);
use LWP::UserAgent;

our $VERSION = '0.03';

sub new {
	my $class = shift;
	my %args = @_;
	my $self = {};
	bless $self;
	
	$self->{'server'} = $args{'-server'} || 
		'http://litmus.mozilla.org/process_test.cgi';
	$self->{'action'} = $args{'-action'} || 'submit';
	$self->requiredField('machinename', %args);
	$self->requiredField('username', %args);
	$self->requiredField('authtoken', %args);	
	
	return $self;
}

sub sysconfig {
	my $self = shift;
	my %args = @_;
	
	$self->requiredField('product', %args);
	$self->requiredField('platform', %args);
	$self->requiredField('opsys', %args);
	$self->requiredField('branch', %args);
	$self->requiredField('buildid', %args);
	$self->requiredField('locale', %args);
	
	$self->{'buildtype'} = $args{'-buildtype'};
}

# add a Test::Litmus::Result object to ourselves
sub addResult {
	my $self = shift;
	my $result = shift;
	push(@{$self->{'results'}}, $result);
}

# add a Test::Litmus::Log object to ourselves
sub addLog {
	my $self = shift;
	my $log = shift;
	push(@{$self->{'logs'}}, $log);
}

# add fieldname to $self unless its missing, at which point we die
sub requiredField {
	my $self = shift;
	my $fieldname = shift;
	my %args = @_;
	
	$self->{$fieldname} = $args{'-'.$fieldname} || 
		die "You must specify a $fieldname";
}

sub errstr {
	my $self = shift;
	return $self->{'response'}->content;
}

sub toXML {
	my $self = shift;
	my $x;
	
	$x  = '<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>'."\n";
 	$x .= '<!DOCTYPE litmusresults PUBLIC 
                      "-//Mozilla Corporation//Litmus Result Submission DTD//EN/"
                      "http://litmus.mozilla.org/litmus_results.dtd">'."\n";
    $x .= '<litmusresults action="'.$self->{'action'}.'" useragent="'.
    	'Test::Litmus/'.$VERSION.' ('.$self->{'machinename'}.')" '.
    	'machinename="'.$self->{'machinename'}.'">'."\n";
    $x .= '  <testresults username="'.$self->{'username'}.'"'."\n";
    $x .= '     authtoken="'.$self->{'authtoken'}.'"'."\n";
    $x .= '     product="'.$self->{'product'}.'"'."\n";
    $x .= '     platform="'.$self->{'platform'}.'"'."\n";
    $x .= '     opsys="'.$self->{'opsys'}.'"'."\n";
    $x .= '     branch="'.$self->{'branch'}.'"'."\n";
    $x .= '     buildid="'.$self->{'buildid'}.'"'."\n";
    $x .= '     locale="'.$self->{'locale'}.'"';
    if ($self->{'buildtype'}) {
    	$x .= "\n".'     buildtype="'.$self->{'buildtype'}.'"'.">\n";
    } else {
    	$x .= ">\n";
    }
    
    if ($self->{'logs'}) {
		my @logs = @{$self->{'logs'}};
		foreach my $curlog (@logs) {
			$x .= $curlog->toXML();
		}
    }
    
    my @results = @{$self->{'results'}}; 
    foreach my $curresult (@results) {
    	$x .= $curresult->toXML();
    }
    
    $x .= '  </testresults>'."\n";
    $x .= '</litmusresults>'."\n";
    
    return $x;
}

sub submit {
	my $self = shift;
	$self->{'ua'} = new LWP::UserAgent;
	$self->{'req'} = POST $self->{'server'}, [ data => $self->toXML() ];
	$self->{'response'} = $self->{'ua'}->request($self->{'req'});
	
	if ($self->{'response'}->content =~ /^ok/i) { return 1 }
	elsif ($self->{'response'}->content =~ /^Error processing result/i) { return 0 }
	else { return undef }
}

1;
__END__