aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Youri/Check/Input/Build
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Youri/Check/Input/Build')
-rw-r--r--lib/Youri/Check/Input/Build/Source.pm109
-rw-r--r--lib/Youri/Check/Input/Build/Source/Iurt.pm117
-rw-r--r--lib/Youri/Check/Input/Build/Source/LBD.pm135
3 files changed, 361 insertions, 0 deletions
diff --git a/lib/Youri/Check/Input/Build/Source.pm b/lib/Youri/Check/Input/Build/Source.pm
new file mode 100644
index 0000000..b377875
--- /dev/null
+++ b/lib/Youri/Check/Input/Build/Source.pm
@@ -0,0 +1,109 @@
+# $Id: Source.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Build::Source;
+
+=head1 NAME
+
+Youri::Check::Input::Build::Source - Abstract build log source
+
+=head1 DESCRIPTION
+
+This abstract class defines the updates source interface for
+L<Youri::Check::Input::Build>.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Build object.
+
+No generic parameters (subclasses may define additional ones).
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ id => '', # object id
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ @_
+ );
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+=head2 get_id()
+
+Returns source identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 fails($name, $version, $release, $arch)
+
+Returns true if build fails for package with given name, version and release on
+given architecture.
+
+=head2 status($name, $version, $release, $arch)
+
+Returns exact build status for package with given name, version and release on
+given architecture. It has to be called after fails().
+
+=head2 url($name, $version, $release, $arch)
+
+Returns URL of information source for package with given name, version and
+release on given architecture. It has to be called after fails().
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item fails
+
+=item status
+
+=item url
+
+=back
+
+=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;
diff --git a/lib/Youri/Check/Input/Build/Source/Iurt.pm b/lib/Youri/Check/Input/Build/Source/Iurt.pm
new file mode 100644
index 0000000..9ab84b4
--- /dev/null
+++ b/lib/Youri/Check/Input/Build/Source/Iurt.pm
@@ -0,0 +1,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;
diff --git a/lib/Youri/Check/Input/Build/Source/LBD.pm b/lib/Youri/Check/Input/Build/Source/LBD.pm
new file mode 100644
index 0000000..599a3da
--- /dev/null
+++ b/lib/Youri/Check/Input/Build/Source/LBD.pm
@@ -0,0 +1,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;
generated by cgit v1.2.1 (git 2.21.0) at 2024-05-22 16:13:47 +0000