File Coverage

blib/lib/Test/Litmus.pm

Criterion	Covered	Total	%
statement	19	88	21.5
branch	0	8	0.0
condition	0	6	0.0
subroutine	7	15	46.6
pod	0	8	0.0
total	26	125	20.8

# 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

# 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  = ''."\n";
 	$x .= '
           "-//Mozilla Corporation//Litmus Result Submission DTD//EN/"
           "http://litmus.mozilla.org/litmus_results.dtd">'."\n";
    $x .= '
106
    	'Test::Litmus/'.$VERSION.' ('.$self->{'machinename'}.')" '.
    	'machinename="'.$self->{'machinename'}.'">'."\n";
    $x .= '
    $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 .= '  '."\n";
    $x .= ''."\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__