1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
# $Id: LBD.pm 574 2005-12-27 14:31:16Z guillomovitch $
package Youri::Check::Input::Build::Source::Iurt;
=head1 NAME
Youri::Check::Input::Build::Source::Iurt - Iurt build log source
=head1 DESCRIPTION
This source plugin for L<Youri::Check::Input::Build> collects build logs
available from a iurt build bot.
=cut
use warnings;
use strict;
use Carp;
use LWP::UserAgent;
use HTML::TokeParser;
use base 'Youri::Check::Input::Build::Source';
my %status = (
install_deps => 0,
build => 1,
binary_test => 2
);
my $pattern = '^('
. join('|', keys %status)
. ')_\S+-[^-]+-[^-]+\.src\.rpm\.\d+\.log$';
=head1 CLASS METHODS
=head2 new(%args)
Creates and returns a new Youri::Check::Input::Build::LBD object.
Specific parameters:
=over
=item url $url
URL of logs for this iurt instance (default:
http://qa.mandriva.com/build/iurt/cooker)
=back
=cut
sub _init {
my $self = shift;
my %options = (
url => 'http://qa.mandriva.com/build/iurt/cooker',
@_
);
$self->{_agent} = LWP::UserAgent->new();
# try to connect to base URL directly, and abort if not available
my $response = $self->{_agent}->head($options{url});
die "Unavailable URL $options{url}: " . $response->status_line()
unless $response->is_success();
$self->{_url} = $options{url};
}
sub fails {
my ($self, $name, $version, $release, $arch) = @_;
my $result;
my $url = "$self->{_url}/$arch/log/$name-$version-$release.src.rpm";
print "Fetching URL $url: " if $self->{_verbose} > 1;
my $response = $self->{_agent}->get($url);
print $response->status_line() . "\n" if $self->{_verbose} > 1;
if ($response->is_success()) {
my $parser = HTML::TokeParser->new(\$response->content());
while (my $token = $parser->get_tag('a')) {
my $href = $token->[1]->{href};
next unless $href =~ /$pattern/o;
my $status = $1;
if (
!$result->{status} ||
$status{$result->{status}} < $status{$status}
) {
$result->{status} = $status;
$result->{url} = $url . '/' . $href;
}
}
}
$self->{_results}->{$name}->{$version}->{$release}->{$arch} = $result;
return $result->{status} && $result->{status} ne 'binary_test';
}
sub status {
my ($self, $name, $version, $release, $arch) = @_;
return
$self->{_results}->{$name}->{$version}->{$release}->{$arch}->{status};
}
sub url {
my ($self, $name, $version, $release, $arch) = @_;
return
$self->{_results}->{$name}->{$version}->{$release}->{$arch}->{url};
}
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2002-2006, YOURI project
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=cut
1;
|
