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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
# $Id: LBD.pm 1179 2006-08-05 08:30:57Z warly $
package Youri::Check::Input::Build::Source::LBD;
=head1 NAME
Youri::Check::Input::Build::Source::LBD - LBD build log source
=head1 DESCRIPTION
This source plugin for L<Youri::Check::Input::Build> collects build logs
available from a LBD build bot.
=cut
use warnings;
use strict;
use Carp;
use LWP::UserAgent;
use HTML::TokeParser;
use base 'Youri::Check::Input::Build::Source';
my @status = qw/
OK
arch_excl
broken
cannot_be_installed
debug
dependency
file_not_found
multiarch
problem
unpackaged_files
/;
=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 LBD instance (default: http://eijk.homelinux.org/build)
=item medias $medias
List of medias monitored by this LBD instance
=item archs $archs
List of architectures monitored by this LBD instance
=back
=cut
sub _init {
my $self = shift;
my %options = (
url => 'http://eijk.homelinux.org/build',
medias => undef,
archs => undef,
@_
);
my $agent = LWP::UserAgent->new();
# try to connect to base URL directly, and abort if not available
my $response = $agent->head($options{url});
die "Unavailable URL $options{url}: " . $response->status_line()
unless $response->is_success();
my $pattern = '^(\S+)-([^-]+)-([^-]+)(?:\.gz)?$';
foreach my $arch (@{$options{archs}}) {
foreach my $media (@{$options{medias}}) {
my $url_base = "$options{url}/$arch/$media/BO";
foreach my $status (@status) {
my $url = "$url_base/$status/";
print "Fetching URL $url: " if $self->{_verbose} > 1;
my $response = $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 $name = $1;
my $version = $2;
my $release = $3;
my $result;
$result->{status} = $status;
$result->{url} = $url . '/' . $href;
$self->{_results}->{$name}->{$version}->{$release}->{$arch} = $result;
}
}
}
}
}
}
sub fails {
my ($self, $name, $version, $release, $arch) = @_;
my $status =
$self->{_results}->{$name}->{$version}->{$release}->{$arch}->{status};
return $status && $status ne 'OK' && $status ne 'arch_excl';
}
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;
|
