From a4f149873af1e9cff9ab0829adfcd3eca1a3780d Mon Sep 17 00:00:00 2001 From: Nicolas Vigier Date: Thu, 6 Jan 2011 01:07:55 +0000 Subject: search in core, nonfree, tainted instead of main, contrib --- lib/Youri/Bugzilla.pm | 482 ++++++++++++++++++ lib/Youri/Check/Input.pm | 120 +++++ lib/Youri/Check/Input/Age.pm | 110 +++++ lib/Youri/Check/Input/Build.pm | 128 +++++ lib/Youri/Check/Input/Build/Source.pm | 109 ++++ lib/Youri/Check/Input/Build/Source/Iurt.pm | 117 +++++ lib/Youri/Check/Input/Build/Source/LBD.pm | 135 +++++ lib/Youri/Check/Input/Conflicts.pm | 231 +++++++++ lib/Youri/Check/Input/Dependencies.pm | 162 ++++++ lib/Youri/Check/Input/MandrivaConflicts.pm | 63 +++ lib/Youri/Check/Input/Missing.pm | 138 ++++++ lib/Youri/Check/Input/Orphans.pm | 74 +++ lib/Youri/Check/Input/Rpmlint.pm | 113 +++++ lib/Youri/Check/Input/Signature.pm | 96 ++++ lib/Youri/Check/Input/Updates.pm | 275 +++++++++++ lib/Youri/Check/Input/Updates/Source.pm | 240 +++++++++ lib/Youri/Check/Input/Updates/Source/CPAN.pm | 75 +++ lib/Youri/Check/Input/Updates/Source/Debian.pm | 82 ++++ lib/Youri/Check/Input/Updates/Source/Fedora.pm | 63 +++ lib/Youri/Check/Input/Updates/Source/Freshmeat.pm | 111 +++++ lib/Youri/Check/Input/Updates/Source/GNOME.pm | 104 ++++ lib/Youri/Check/Input/Updates/Source/Gentoo.pm | 75 +++ lib/Youri/Check/Input/Updates/Source/NetBSD.pm | 75 +++ lib/Youri/Check/Input/Updates/Source/RAA.pm | 121 +++++ .../Check/Input/Updates/Source/Sourceforge.pm | 103 ++++ lib/Youri/Check/Maintainer/Preferences.pm | 80 +++ lib/Youri/Check/Maintainer/Preferences/File.pm | 87 ++++ lib/Youri/Check/Maintainer/Resolver.pm | 86 ++++ lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm | 100 ++++ lib/Youri/Check/Maintainer/Resolver/CGI.pm | 79 +++ lib/Youri/Check/Output.pm | 190 +++++++ lib/Youri/Check/Output/File.pm | 203 ++++++++ lib/Youri/Check/Output/File/Format.pm | 66 +++ lib/Youri/Check/Output/File/Format/HTML.pm | 222 +++++++++ lib/Youri/Check/Output/File/Format/RSS.pm | 68 +++ lib/Youri/Check/Output/File/Format/Text.pm | 88 ++++ lib/Youri/Check/Output/Mail.pm | 156 ++++++ lib/Youri/Check/Output/Mail/Format.pm | 66 +++ lib/Youri/Check/Output/Mail/Format/HTML.pm | 158 ++++++ lib/Youri/Check/Output/Mail/Format/Text.pm | 83 ++++ lib/Youri/Check/Resultset.pm | 116 +++++ lib/Youri/Check/Resultset/DBI.pm | 372 ++++++++++++++ lib/Youri/Check/Resultset/Iterator.pm | 22 + lib/Youri/Config.pm | 202 ++++++++ lib/Youri/Media.pm | 311 ++++++++++++ lib/Youri/Media/URPM.pm | 273 +++++++++++ lib/Youri/Package.pm | 336 +++++++++++++ lib/Youri/Package/RPM.pm | 58 +++ lib/Youri/Package/RPM4.pm | 424 ++++++++++++++++ lib/Youri/Package/Test.pm | 151 ++++++ lib/Youri/Package/URPM.pm | 399 +++++++++++++++ lib/Youri/Repository.pm | 492 +++++++++++++++++++ lib/Youri/Repository/Mandriva_upload.pm | 546 +++++++++++++++++++++ lib/Youri/Repository/Mandriva_upload_pre.pm | 276 +++++++++++ lib/Youri/Repository/PLF.pm | 196 ++++++++ lib/Youri/Utils.pm | 98 ++++ 56 files changed, 9406 insertions(+) create mode 100644 lib/Youri/Bugzilla.pm create mode 100644 lib/Youri/Check/Input.pm create mode 100644 lib/Youri/Check/Input/Age.pm create mode 100644 lib/Youri/Check/Input/Build.pm create mode 100644 lib/Youri/Check/Input/Build/Source.pm create mode 100644 lib/Youri/Check/Input/Build/Source/Iurt.pm create mode 100644 lib/Youri/Check/Input/Build/Source/LBD.pm create mode 100644 lib/Youri/Check/Input/Conflicts.pm create mode 100644 lib/Youri/Check/Input/Dependencies.pm create mode 100644 lib/Youri/Check/Input/MandrivaConflicts.pm create mode 100644 lib/Youri/Check/Input/Missing.pm create mode 100644 lib/Youri/Check/Input/Orphans.pm create mode 100644 lib/Youri/Check/Input/Rpmlint.pm create mode 100644 lib/Youri/Check/Input/Signature.pm create mode 100644 lib/Youri/Check/Input/Updates.pm create mode 100644 lib/Youri/Check/Input/Updates/Source.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/CPAN.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/Debian.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/Fedora.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/Freshmeat.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/GNOME.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/Gentoo.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/NetBSD.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/RAA.pm create mode 100644 lib/Youri/Check/Input/Updates/Source/Sourceforge.pm create mode 100644 lib/Youri/Check/Maintainer/Preferences.pm create mode 100644 lib/Youri/Check/Maintainer/Preferences/File.pm create mode 100644 lib/Youri/Check/Maintainer/Resolver.pm create mode 100644 lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm create mode 100644 lib/Youri/Check/Maintainer/Resolver/CGI.pm create mode 100644 lib/Youri/Check/Output.pm create mode 100644 lib/Youri/Check/Output/File.pm create mode 100644 lib/Youri/Check/Output/File/Format.pm create mode 100644 lib/Youri/Check/Output/File/Format/HTML.pm create mode 100644 lib/Youri/Check/Output/File/Format/RSS.pm create mode 100644 lib/Youri/Check/Output/File/Format/Text.pm create mode 100644 lib/Youri/Check/Output/Mail.pm create mode 100644 lib/Youri/Check/Output/Mail/Format.pm create mode 100644 lib/Youri/Check/Output/Mail/Format/HTML.pm create mode 100644 lib/Youri/Check/Output/Mail/Format/Text.pm create mode 100644 lib/Youri/Check/Resultset.pm create mode 100644 lib/Youri/Check/Resultset/DBI.pm create mode 100644 lib/Youri/Check/Resultset/Iterator.pm create mode 100644 lib/Youri/Config.pm create mode 100644 lib/Youri/Media.pm create mode 100644 lib/Youri/Media/URPM.pm create mode 100644 lib/Youri/Package.pm create mode 100644 lib/Youri/Package/RPM.pm create mode 100644 lib/Youri/Package/RPM4.pm create mode 100644 lib/Youri/Package/Test.pm create mode 100644 lib/Youri/Package/URPM.pm create mode 100644 lib/Youri/Repository.pm create mode 100644 lib/Youri/Repository/Mandriva_upload.pm create mode 100644 lib/Youri/Repository/Mandriva_upload_pre.pm create mode 100644 lib/Youri/Repository/PLF.pm create mode 100644 lib/Youri/Utils.pm (limited to 'lib/Youri') diff --git a/lib/Youri/Bugzilla.pm b/lib/Youri/Bugzilla.pm new file mode 100644 index 0000000..098de0e --- /dev/null +++ b/lib/Youri/Bugzilla.pm @@ -0,0 +1,482 @@ +# $Id: Bugzilla.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Bugzilla; + +=head1 NAME + +Youri::Bugzilla - Youri Bugzilla interface + +=head1 SYNOPSIS + + use Youri::Bugzilla; + + my $bugzilla = Youri::Bugzilla->new($host, $base, $user, $pass); + + print $bugzilla->get_maintainer('foobar'); + +=head1 DESCRIPTION + +This module implement a database-level Bugzilla interface for managing packages. + +The legacy Bugzilla database model is mapped this way: + +=over + +=item * + +a maintainer is a user + +=item * + +a package is a product + +=item * + +each package has two pseudo components "program" and "package", owned by the package maintainer + +=back + +=cut + +use DBI; +use Carp; +use strict; +use warnings; + +my %queries = ( + get_package_id => 'SELECT id FROM products WHERE name = ?', + get_maintainer_id => 'SELECT userid FROM profiles WHERE login_name = ?', + get_versions => 'SELECT value FROM versions WHERE product_id = ?', + get_components => 'SELECT name FROM components WHERE product_id = ?', + add_package => 'INSERT INTO products (name, description) VALUES (?, ?)', + add_maintainer => 'INSERT INTO profiles (login_name, cryptpassword, realname, emailflags, refreshed_when) VALUES (?, ENCRYPT(?), ?, ?, SYSDATE())', + add_component => 'INSERT INTO components (product_id, name, description,initialowner, initialqacontact) VALUES (?, ?, ?, ?, ?)', + add_version => 'INSERT INTO versions (product_id, value) VALUES (?, ?)', + del_package => 'DELETE FROM products WHERE product = ?', + del_maintainer => 'DELETE FROM profiles WHERE login_name = ?', + del_components => 'DELETE FROM components WHERE program = ?', + del_versions => 'DELETE FROM versions WHERE program = ?', + reset_password => 'UPDATE profiles SET cryptpassword = ENCRYPT(?) WHERE login_name = ?', + browse_packages => < < object, wrapping bugzilla database I<$base> +hosted on I<$host>, and accessed by user I<$user> with password I<$password>. + +=cut + +sub new { + my ($class, $host, $base, $user, $pass) = @_; + + my $dbh = DBI->connect("DBI:mysql:database=$base;host=$host", $user, $pass) or croak "Unable to connect: $DBI::errstr"; + + my $self = bless { + _dbh => $dbh + }, $class; + + return $self; +} + +=head1 INSTANCE METHODS + +=head2 has_package($package) + +Return true if bugzilla contains given package. + +=cut + +sub has_package { + my ($self, $package) = @_; + return $self->_get_package_id($package); +} + +=head2 has_maintainer($maintainer) + +Return true if bugzilla contains given maintainer. + +=cut + +sub has_maintainer { + my ($self, $maintainer) = @_; + return $self->_get_maintainer_id($maintainer); +} + +=head2 get_maintainer($package) + +Return maintainer of given package. + +=cut + +sub get_maintainer { + my ($self, $package) = @_; + return $self->_get_single('get_maintainer', $package); +} + +=head2 get_versions($package) + +Return versions from given package. + +=cut + +sub get_versions { + my ($self, $package) = @_; + return $self->_get_multiple( + 'get_versions', + $self->_get_package_id($package) + ); +} + +=head2 get_components($package) + +Return components from given package. + +=cut + +sub get_components { + my ($self, $package) = @_; + return $self->_get_multiple( + 'get_components', + $self->_get_package_id($package) + ); +} + +=head2 get_packages() + +Return all packages from the database. + +=cut + +sub get_packages { + my ($self) = @_; + return $self->_get_multiple('get_packages'); +} + +sub _get_package_id { + my ($self, $package) = @_; + return $self->_get_single('get_package_id', $package); +} + +sub _get_maintainer_id { + my ($self, $maintainer) = @_; + return $self->_get_single('get_maintainer_id', $maintainer); +} + +sub _get_single { + my ($self, $type, $value) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{$type}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{$type}); + $self->{_queries}->{$type} = $query; + } + + $query->execute($value); + + my @row = $query->fetchrow_array(); + return @row ? $row[0]: undef; +} + +sub _get_multiple { + my ($self, $type, $value) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{$type}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{$type}); + $self->{_queries}->{$type} = $query; + } + + $query->execute($value); + + my @results; + while (my @row = $query->fetchrow_array()) { + push @results, $row[0]; + } + return @results; +} + +=head2 add_package($name, $summary, $version, $maintainer, $contact) + +Adds a new package in the database, with given name, summary, version, +maintainer and initial QA contact. + +=cut + +sub add_package { + my ($self, $name, $summary, $version, $maintainer, $contact) = @_; + return unless ref $self; + + my $maintainer_id = $self->_get_maintainer_id($maintainer); + unless ($maintainer_id) { + carp "Unknown maintainer $maintainer, aborting"; + return; + } + + my $contact_id = $self->_get_maintainer_id($contact); + unless ($contact_id) { + carp "Unknown QA contact $contact, aborting"; + return; + } + + my $query = $self->{_queries}->{add_package}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_package}); + $self->{_queries}->{add_package} = $query; + } + + $query->execute($name, $summary); + + my $package_id = $self->_get_package_id($name); + + $self->_add_version($package_id, $version); + $self->_add_component( + $package_id, + 'package', + 'problem related to the package', + $maintainer_id, + $contact_id + ); + $self->_add_component( + $package_id, + 'program', + 'problem related to the program', + $maintainer_id, + $contact_id + ); +} + +=head2 add_version($package, $version) + +Adds a new version to given package. + +=cut + +sub add_version { + my ($self, $package, $version) = @_; + return unless ref $self; + + my $package_id = $self->_get_package_id($package); + $self->_add_version($package_id, $version); +} + +sub _add_version { + my ($self, $package_id, $version) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{add_version}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_version}); + $self->{_queries}->{add_version} = $query; + } + + $query->execute($package_id, $version); +} + + +=head2 add_maintainer($name, $login, $password) + +Adds a new maintainer in the database, with given name, login and password. + +=cut + +sub add_maintainer { + my ($self, $name, $login, $pass) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{add_maintainer}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_maintainer}); + $self->{_queries}->{add_maintainer} = $query; + } + + $query->execute($login, $pass, $name, $default_flags); +} + +sub _add_component { + my ($self, $package_id, $name, $description, $maintainer_id, $contact_id) = @_; + + my $query = $self->{_queries}->{add_component}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_component}); + $self->{_queries}->{add_component} = $query; + } + + $query->execute($package_id, $name, $description, $maintainer_id, $contact_id); +} + +=head2 del_package($package) + +Delete given package from database. + +=cut + +sub del_package { + my ($self, $package) = @_; + $self->_delete('del_package', $package); + $self->_delete('del_versions', $package); + $self->_delete('del_components', $package); +} + +=head2 del_maintainer($maintainer) + +Delete given maintainer from database. + +=cut + +sub del_maintainer { + my ($self, $maintainer) = @_; + $self->_delete('del_maintainer', $maintainer); +} + +sub _delete { + my ($self, $type, $value) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{$type}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{$type}); + $self->{_queries}->{$type} = $query; + } + + $query->execute($value); +} + +=head2 reset_password(I<$maintainer>, I<$password>) + +Reset password of a maintainer to given password. + +=cut + +sub reset_password { + my ($self, $login, $pass) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{reset_password}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{reset_password}); + $self->{_queries}->{reset_password} = $query; + } + + $query->execute($pass, $login); +} + +=head2 browse_packages($callback) + +Browse all packages from bugzilla, and execute given callback with name and +maintainer as argument for each of them. + +=cut + +sub browse_packages { + my ($self, $callback) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{browse_packages}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{browse_packages}); + $self->{_queries}->{browse_packages} = $query; + } + + $query->execute(); + + while (my @row = $query->fetchrow_array()) { + $callback->(@row); + } +} + +# close database connection +sub DESTROY { + my ($self) = @_; + + foreach my $query (values %{$self->{_queries}}) { + $query->finish(); + } + + $self->{_dbh}->disconnect(); +} + +=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.pm b/lib/Youri/Check/Input.pm new file mode 100644 index 0000000..d6a4bad --- /dev/null +++ b/lib/Youri/Check/Input.pm @@ -0,0 +1,120 @@ +# $Id: Input.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input; + +=head1 NAME + +Youri::Check::Input - Abstract input plugin + +=head1 DESCRIPTION + +This abstract class defines input plugin interface. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Utils; + +use constant WARNING => 'warning'; +use constant ERROR => 'error'; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input 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 + resolver => undef, # maintainer resolver + preferences => undef, # maintainer preferences + @_ + ); + + if ($options{resolver}) { + croak "resolver should be a Youri::Check::Maintainer::Resolver object" unless $options{resolver}->isa("Youri::Check::Maintainer::Resolver"); + } + if ($options{preferences}) { + croak "preferences should be a Youri::Check::Maintainer::Preferences object" unless $options{preferences}->isa("Youri::Check::Maintainer::Preferences"); + } + + my $self = bless { + _id => $options{id}, + _test => $options{test}, + _verbose => $options{verbose}, + _resolver => $options{resolver}, + _preferences => $options{preferences}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head1 INSTANCE METHODS + +=head2 get_id() + +Returns plugin identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=head2 prepare(@medias) + +Perform optional preliminary initialisation, using given list of + objects. + +=cut + +sub prepare { + # do nothing +} + +=head2 run($media, $resultset) + +Check the packages from given L object, and store the +result in given L object. + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item run + +=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/Age.pm b/lib/Youri/Check/Input/Age.pm new file mode 100644 index 0000000..fda4222 --- /dev/null +++ b/lib/Youri/Check/Input/Age.pm @@ -0,0 +1,110 @@ +# $Id: Age.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Age; + +=head1 NAME + +Youri::Check::Input::Age - Check maximum age + +=head1 DESCRIPTION + +This plugin checks packages age, and report the ones exceeding maximum limit. + +=cut + +use warnings; +use strict; +use Carp; +use DateTime; +use DateTime::Format::Duration; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + arch + buildtime + /; +} + +sub links { + return qw//; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Age object. + +Specific parameters: + +=over + +=item max_age $age + +Maximum age allowed (default: 1 year) + +=item pattern $pattern + +Pattern used to describe age (default: %Y year) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + max_age => '1 year', + pattern => '%Y year', + @_ + ); + + $self->{_format} = DateTime::Format::Duration->new( + pattern => $options{pattern} + ); + + $self->{_now} = DateTime->from_epoch( + epoch => time() + ); + + $self->{_max_age} = $options{max_age}; +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + my $max_age_string = $media->max_age() ? + $media->max_age() : + $self->{_max_age}; + + my $max_age = $self->{_format}->parse_duration($max_age_string); + + my $check = sub { + my ($package) = @_; + + my $buildtime = DateTime->from_epoch( + epoch => $package->get_age() + ); + + my $age = $self->{_now}->subtract_datetime($buildtime); + + if (DateTime::Duration->compare($age, $max_age) > 0) { + my $date = $buildtime->strftime("%a %d %b %G"); + + $resultset->add_result($self->{_id}, $media, $package, { + arch => $package->get_arch(), + buildtime => $date + }); + } + }; + $media->traverse_headers($check); +} + +=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.pm b/lib/Youri/Check/Input/Build.pm new file mode 100644 index 0000000..2b4e3a6 --- /dev/null +++ b/lib/Youri/Check/Input/Build.pm @@ -0,0 +1,128 @@ +# $Id: Build.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Build; + +=head1 NAME + +Youri::Check::Input::Build - Check build outputs + +=head1 DESCRIPTION + +This plugin checks build outputs of packages, and report failures. Additional +source plugins handle specific sources. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Utils; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + arch + bot + status + /; +} + +sub links { + return qw/ + status url + /; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Build object. + +Specific parameters: + +=over + +=item sources $sources + +Hash of source plugins definitions + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + sources => undef, + @_ + ); + + croak "No source defined" unless $options{sources}; + croak "sources should be an hashref" unless ref $options{sources} eq 'HASH'; + + foreach my $id (keys %{$options{sources}}) { + print "Creating source $id\n" if $options{verbose}; + eval { + push( + @{$self->{_sources}}, + create_instance( + 'Youri::Check::Input::Build::Source', + id => $id, + test => $options{test}, + verbose => $options{verbose}, + %{$options{sources}->{$id}} + ) + ); + # register monitored archs + $self->{_archs}->{$_}->{$id} = 1 + foreach @{$options{sources}->{$id}->{archs}}; + }; + print STDERR "Failed to create source $id: $@\n" if $@; + } + + croak "no sources created" unless @{$self->{_sources}}; +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + # this is a source media check only + return unless $media->get_type() eq 'source'; + + my $callback = sub { + my ($package) = @_; + + my $name = $package->get_name(); + my $version = $package->get_version(); + my $release = $package->get_release(); + + foreach my $source (@{$self->{_sources}}) { + my $id = $source->get_id(); + foreach my $arch (keys %{$self->{_archs}}) { + next unless $self->{_archs}->{$arch}->{$id}; + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + bot => $id, + status => $source->status($name, $version, $release, $arch), + url => $source->url($name, $version, $release, $arch), + }) if $source->fails( + $name, + $version, + $release, + $arch, + ); + } + } + }; + + $media->traverse_headers($callback); +} + +=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.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. + +=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 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 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; diff --git a/lib/Youri/Check/Input/Conflicts.pm b/lib/Youri/Check/Input/Conflicts.pm new file mode 100644 index 0000000..88cb2f6 --- /dev/null +++ b/lib/Youri/Check/Input/Conflicts.pm @@ -0,0 +1,231 @@ +# $Id: Conflicts.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Conflicts; + +=head1 NAME + +Youri::Check::Input::Conflicts - Check file conflicts + +=head1 DESCRIPTION + +This plugin checks packages files, and report conflict and duplications. + +=cut + +use warnings; +use strict; +use Carp; +use constant; +use Youri::Package; +use base 'Youri::Check::Input'; + +use constant TYPE_MASK => 0170000; +use constant TYPE_DIR => 0040000; + +use constant PACKAGE => 0; +use constant MODE => 1; +use constant MD5SUM => 2; + +my $compatibility = { + x86_64 => 'i586', + i586 => 'x86_64', + sparc64 => 'sparc', + sparc => 'sparc64', + ppc64 => 'ppc', + ppc => 'ppc64' +}; + +sub columns { + return qw/ + arch + file + error + level + /; +} + +sub links { + return qw//; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Conflicts object. + +No specific parameters. + +=cut + +sub prepare { + my ($self, @medias) = @_; + croak "Not a class method" unless ref $self; + + my $index = sub { + my ($package) = @_; + + # index files + foreach my $file ($package->get_files()) { + push( + @{$self->{_files}->{$file->[Youri::Package::FILE_NAME]}}, + [ $package, $file->[Youri::Package::FILE_MODE], $file->[Youri::Package::FILE_MD5SUM] ] + ); + } + }; + + foreach my $media (@medias) { + # don't index source media files + next unless $media->get_type() eq 'binary'; + + my $media_id = $media->get_id(); + $self->{_medias}->{$media_id} = 1; + print STDERR "Indexing media $media_id files\n" + if $self->{_verbose}; + + $media->traverse_headers($index); + } +} + +sub run { + my ($self, $media, $result) = @_; + croak "Not a class method" unless ref $self; + + # this is a binary media check only + return unless $media->get_type() eq 'binary'; + + my $check = sub { + my ($package) = @_; + + return if $package->get_arch() eq 'src'; + + my $arch = $package->get_arch(); + my $name = $package->get_name(); + + foreach my $file ($package->get_files()) { + + my $found = + $self->{_files}->{$file->[Youri::Package::FILE_NAME]}; + + my @found = $found ? @$found : (); + + foreach my $found (@found) { + next if $found->[PACKAGE] == $package; + next unless compatible($found->[PACKAGE], $package); + next if conflict($found->[PACKAGE], $package); + next if replace($found->[PACKAGE], $package); + if ( + ($file->[Youri::Package::FILE_MODE] & TYPE_MASK) == TYPE_DIR && + ($found->[MODE] & TYPE_MASK) == TYPE_DIR + ) { + $result->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "directory $file->[Youri::Package::FILE_NAME] duplicated with package " . $found->[PACKAGE]->get_name(), + level => Youri::Check::Input::WARNING + }) unless $self->_directory_duplicate_exception( + $package, + $found->[PACKAGE], + $file + ); + } else { + if ($found->[MD5SUM] eq $file->[Youri::Package::FILE_MD5SUM]) { + $result->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "file $file->[Youri::Package::FILE_NAME] duplicated with package " . $found->[PACKAGE]->get_name(), + level => Youri::Check::Input::WARNING + }) unless $self->_file_duplicate_exception( + $package, + $found->[PACKAGE], + $file + ); + } else { + $result->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "non-explicit conflict on file $file->[Youri::Package::FILE_NAME] with package " . $found->[PACKAGE]->get_name(), + level => Youri::Check::Input::ERROR + }) unless $self->_file_conflict_exception( + $package, + $found->[PACKAGE], + $file + ); + } + } + } + } + }; + + $media->traverse_headers($check); +} + +# return true if $package1 is arch-compatible with $package2 +sub compatible { + my ($package1, $package2) = @_; + + my $arch1 = $package1->get_arch(); + my $arch2 = $package2->get_arch(); + + return 1 if $arch1 eq $arch2; + + return 1 if $compatibility->{$arch1} && $compatibility->{$arch1} eq $arch2; + + return 0; +} + +# return true if $package1 conflict with $package2 +# or the other way around +sub conflict { + my ($package1, $package2) = @_; + + my $name2 = $package2->get_name(); + + foreach my $conflict ($package1->get_conflicts()) { + return 1 if $conflict eq $name2; + } + + my $name1 = $package1->get_name(); + + foreach my $conflict ($package2->get_conflicts()) { + return 1 if $conflict eq $name1; + } + + return 0; +} + +# return true if $package1 replace $package2 +sub replace { + my ($package1, $package2) = @_; + + + my $name1 = $package1->get_name(); + my $name2 = $package2->get_name(); + + return 1 if $name1 eq $name2; + + foreach my $obsolete ($package1->get_obsoletes()) { + return 1 if $obsolete->[Youri::Package::DEPENDENCY_NAME] eq $name2; + } + + return 0; +} + +sub _directory_duplicate_exception { + return 0; +} + +sub _file_duplicate_exception { + return 0; +} + +sub _file_conflict_exception { + return 0; +} + +=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/Dependencies.pm b/lib/Youri/Check/Input/Dependencies.pm new file mode 100644 index 0000000..6f148d5 --- /dev/null +++ b/lib/Youri/Check/Input/Dependencies.pm @@ -0,0 +1,162 @@ +# $Id: Dependencies.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Dependencies; + +=head1 NAME + +Youri::Check::Input::Dependencies - Check dependencies consistency + +=head1 DESCRIPTION + +This class checks dependencies consistency. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Package; +use base 'Youri::Check::Input'; + +use constant MEDIA => 0; +use constant RANGE => 1; + +sub columns { + return qw/ + arch + file + error + level + /; +} + +sub links { + return qw//; +} + +sub prepare { + my ($self, @medias) = @_; + croak "Not a class method" unless ref $self; + + foreach my $media (@medias) { + my $media_id = $media->get_id(); + $self->{_medias}->{$media_id} = 1; + print STDERR "Indexing media $media_id dependencies\n" + if $self->{_verbose}; + + my $index = sub { + my ($package) = @_; + + # index provides + foreach my $provide ($package->get_provides()) { + push( + @{$self->{_provides}->{$provide->[Youri::Package::DEPENDENCY_NAME]}}, + [ $media_id, $provide->[Youri::Package::DEPENDENCY_RANGE] ] + ); + } + + # index files + foreach my $file ($package->get_files()) { + push( + @{$self->{_files}->{$file->[Youri::Package::FILE_NAME]}}, + [ $media_id, undef ] + ); + } + }; + $media->traverse_headers($index); + } +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + my @allowed_ids = $media->allow_deps(); + + # abort unless all allowed medias are present + foreach my $id (@allowed_ids) { + unless ($self->{_medias}->{$id}) { + carp "Missing media $id, aborting"; + return; + } + } + + # index allowed medias + my %allowed_ids = map { $_ => 1 } @allowed_ids; + my $allowed_ids = join(",", @allowed_ids); + + my $class = $media->get_package_class(); + + my $check = sub { + my ($package) = @_; + + my $arch = $package->get_arch(); + my $name = $package->get_name(); + + foreach my $require ($package->get_requires()) { + + my $found = + substr($require->[Youri::Package::DEPENDENCY_NAME], 0, 1) eq '/' ? + $self->{_files}->{$require->[Youri::Package::DEPENDENCY_NAME]} : + $self->{_provides}->{$require->[Youri::Package::DEPENDENCY_NAME]}; + + my @found = $found ? @$found : (); + + if (!@found) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "$require->[Youri::Package::DEPENDENCY_NAME] not found", + level => Youri::Check::Input::ERROR + }); + next; + } + + my @found_in_media = + grep { $allowed_ids{$_->[MEDIA]} } + @found; + + if (!@found_in_media) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "$require->[Youri::Package::DEPENDENCY_NAME] found in incorrect media $_->[MEDIA] (allowed $allowed_ids)", + level => Youri::Check::Input::ERROR + }) foreach @found; + next; + } + + next unless $require->[Youri::Package::DEPENDENCY_RANGE]; + + my @found_in_range = + grep { + !$_->[RANGE] || + $class->compare_ranges( + $require->[Youri::Package::DEPENDENCY_RANGE], + $_->[RANGE] + ) + } @found_in_media; + + if (!@found_in_range) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "$require->[Youri::Package::DEPENDENCY_NAME] found with incorrect range $_->[RANGE] (needed $require->[Youri::Package::DEPENDENCY_RANGE])", + level => Youri::Check::Input::ERROR + }) foreach @found_in_media; + next; + } + } + }; + + $media->traverse_headers($check); +} + +=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/MandrivaConflicts.pm b/lib/Youri/Check/Input/MandrivaConflicts.pm new file mode 100644 index 0000000..c43623b --- /dev/null +++ b/lib/Youri/Check/Input/MandrivaConflicts.pm @@ -0,0 +1,63 @@ +# $Id: Conflicts.pm 533 2005-10-20 07:08:03Z guillomovitch $ +package Youri::Check::Input::MandrivaConflicts; + +=head1 NAME + +Youri::Check::Input::MandrivaConflicts - Check file conflicts on Mandriva + +=head1 DESCRIPTION + +This class checks file conflicts between packages, taking care of Mandriva +packaging policy. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Package; +use base 'Youri::Check::Input::Conflicts'; + +sub _directory_duplicate_exception { + my ($self, $package1, $package2, $file) = @_; + + # allow shared directories between devel packages of different arch + return 1 if _multiarch_exception($package1, $package2); + + # allow shared modules directories between perl packages + return 1 if + $file->[Youri::Package::FILE_NAME] =~ /^\/usr\/lib\/perl5\/vendor_perl\// && + $file->[Youri::Package::FILE_NAME] !~ /^(auto|[^\/]+-linux)$/; + + return 0; +} + +sub _file_duplicate_exception { + my ($self, $package1, $package2, $file) = @_; + + # allow shared files between devel packages of different arch + return 1 if _multiarch_exception($package1, $package2); + + return 0; +} + +sub _multiarch_exception { + my ($package1, $package2) = @_; + + return 1 if + $package1->get_canonical_name() eq $package2->get_canonical_name() + && $package1->get_name() =~ /-devel$/ + && $package2->get_name() =~ /-devel$/; + + return 0; +} + +=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/Missing.pm b/lib/Youri/Check/Input/Missing.pm new file mode 100644 index 0000000..ece034d --- /dev/null +++ b/lib/Youri/Check/Input/Missing.pm @@ -0,0 +1,138 @@ +package Youri::Check::Input::Missing; + +=head1 NAME + +Youri::Check::Input::Missing - Check components consistency + +=head1 DESCRIPTION + +This plugin checks consistency between package components, and report outdated +ones. + +=cut + +use warnings; +use strict; +use Carp; +use List::MoreUtils qw/all any/; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + component + arch + revision + error + /; +} + +sub links { + return qw//; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Missing object. + +No specific parameters. + +=cut + +sub prepare { + my ($self, @medias) = @_; + croak "Not a class method" unless ref $self; + $self->{_srcs} = (); + foreach my $media (@medias) { + # only index source media + next unless $media->get_type() eq 'source'; + + my $media_id = $media->get_id(); + $self->{_medias}->{$media_id} = 1; + print STDERR "Indexing media $media_id packages\n" if $self->{_verbose}; + + my $index = sub { + my ($package) = @_; + $self->{_srcs}->{$media_id}->{$package->get_name()} = + $package->get_version() . '-' . $package->get_release(); + }; + + $media->traverse_headers($index); + } +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + # this is a binary media check only + return unless $media->get_type() eq 'binary'; + + my @allowed_ids = $media->allow_srcs(); + + # abort unless all allowed medias are present + foreach my $id (@allowed_ids) { + unless ($self->{_medias}->{$id}) { + carp "Missing media $id, aborting"; + return; + } + } + + my $class = $media->get_package_class(); + + my $check_package = sub { + my ($package) = @_; + my $canonical_name = $package->get_canonical_name(); + + my $bin_revision = + $package->get_version() . '-' . $package->get_release(); + + my $src_revision; + foreach my $id (@allowed_ids) { + $src_revision = $self->{_srcs}->{$id}->{$canonical_name}; + last if $src_revision; + } + + if ($src_revision) { + # check if revision match + unless ($src_revision eq $bin_revision) { + if ($class->compare_versions($src_revision, $bin_revision) > 0) { + # binary package is obsolete + $resultset->add_result($self->{_id}, $media, $package, { + component => $package->get_name(), + arch => $package->get_arch(), + revision => $bin_revision, + error => "Obsolete binaries (source $src_revision found)", + }); + } else { + # source package is obsolete + $resultset->add_result($self->{_id}, $media, $package, { + component => $package->get_canonical_name(), + arch => 'src', + revision => $src_revision, + error => "Obsolete source (binaries $bin_revision found)", + }); + } + } + } else { + $resultset->add_result($self->{_id}, $media, $package, { + component => $package->get_name(), + arch => $package->get_arch(), + revision => $bin_revision, + error => "Missing source package", + }); + } + }; + + $media->traverse_headers($check_package); +} + + +=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/Orphans.pm b/lib/Youri/Check/Input/Orphans.pm new file mode 100644 index 0000000..e193f0e --- /dev/null +++ b/lib/Youri/Check/Input/Orphans.pm @@ -0,0 +1,74 @@ +package Youri::Check::Input::Orphans; + +=head1 NAME + +Youri::Check::Input::Orphans - Check maintainance + +=head1 DESCRIPTION + +This plugin checks maintainance status of packages, and reports unmaintained +ones. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + error + /; +} + +sub links { + return qw//; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Orphans object. + +No specific parameters. + +=cut + +sub _init { + my $self = shift; + my %options = ( + resolver => undef, + @_ + ); + + croak "No resolver defined" unless $options{resolver}; + + $self->{_resolver} = $options{resolver}; +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + # this is a source media check only + return unless $media->get_type() eq 'source'; + + my $check = sub { + my ($package) = @_; + $resultset->add_result($self->{_id}, $media, $package, { + error => "unmaintained package" + }) unless $self->{_resolver}->get_maintainer($package); + }; + + $media->traverse_headers($check); +} + +=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/Rpmlint.pm b/lib/Youri/Check/Input/Rpmlint.pm new file mode 100644 index 0000000..3148ca4 --- /dev/null +++ b/lib/Youri/Check/Input/Rpmlint.pm @@ -0,0 +1,113 @@ +# $Id: Rpmlint.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Rpmlint; + +=head1 NAME + +Youri::Check::Input::Rpmlint - Check packages with rpmlint + +=head1 DESCRIPTION + +This plugins checks packages with rpmlint, and reports output. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + arch + file + error + level + /; +} + +sub links { + return qw//; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Rpmlint object. + +Specific parameters: + +=over + +=item path $path + +Path to the rpmlint executable (default: /usr/bin/rpmlint) + +=item config $config + +Specific rpmlint configuration. + +=back + +=cut + + +sub _init { + my $self = shift; + my %options = ( + path => '/usr/bin/rpmlint', # path to rpmlint + config => '', # default rpmlint configuration + @_ + ); + + $self->{_path} = $options{path}; + $self->{_config} = $options{config}; +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + my $config = $media->rpmlint_config() ? + $media->rpmlint_config() : + $self->{_config}; + + my $check = sub { + my ($file, $package) = @_; + + my $arch = $package->get_arch(); + my $name = $package->get_name(); + + my $command = "$self->{_path} -f $config $file"; + open(RPMLINT, "$command |") or die "Can't run $command: $!"; + while () { + chomp; + if (/^E: \Q$name\E (.+)/) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => $1, + level => Youri::Check::Input::ERROR + }); + } elsif (/^W: \Q$name\E (.+)/) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => $1, + level => Youri::Check::Input::WARNING + }); + } + } + close(RPMLINT); + }; + + $media->traverse_files($check); +} + +=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/Signature.pm b/lib/Youri/Check/Input/Signature.pm new file mode 100644 index 0000000..57b49bc --- /dev/null +++ b/lib/Youri/Check/Input/Signature.pm @@ -0,0 +1,96 @@ +# $Id: Rpmlint.pm 567 2005-12-12 21:24:56Z guillomovitch $ +package Youri::Check::Input::Signature; + +=head1 NAME + +Youri::Check::Input::Signature - Check signature + +=head1 DESCRIPTION + +This plugin checks packages signature, and report unsigned ones. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + arch + file + error + /; +} + +sub links { + return qw//; +} + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Signature object. + +Specific parameters: + +=over + +=item key $key + +Expected GPG key identity + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + key => '', + @_ + ); + + $self->{_key} = $options{key}; +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + my $check = sub { + my ($package) = @_; + + my $arch = $package->get_arch(); + my $name = $package->get_name(); + + my $key = $package->get_gpg_key(); + + if (!$key) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "unsigned package $name" + }); + } elsif ($key ne $self->{_key}) { + $resultset->add_result($self->{_id}, $media, $package, { + arch => $arch, + file => $name, + error => "invalid key id $key for package $name (allowed $self->{_key})" + }); + } + + }; + + $media->traverse_headers($check); +} + +=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/Updates.pm b/lib/Youri/Check/Input/Updates.pm new file mode 100644 index 0000000..a61ce5e --- /dev/null +++ b/lib/Youri/Check/Input/Updates.pm @@ -0,0 +1,275 @@ +# $Id: Updates.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates; + +=head1 NAME + +Youri::Check::Input::Updates - Check available updates + +=head1 DESCRIPTION + +This plugin checks available updates for packages, and report existing ones. +Additional source plugins handle specific sources. + +=cut + +use warnings; +use strict; +use Carp; +use Memoize; +use Youri::Utils; +use base 'Youri::Check::Input'; + +sub columns { + return qw/ + current + available + source + /; +} + +sub links { + return qw/ + source url + /; +} + +memoize('is_newer'); + +our $VERSION_REGEXP = 'v?([\d._-]*\d)[._ -]*(?:(alpha|beta|pre|rc|pl|rev|cvs|svn|[a-z])[_ -.]*([\d.]*))?([_ -.]*.*)'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates object. + +Specific parameters: + +=over + +=item aliases $aliases + +Hash of global aliases definitions + +=item sources $sources + +Hash of source plugins definitions + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + aliases => undef, + sources => undef, + @_ + ); + + croak "No source defined" unless $options{sources}; + croak "sources should be an hashref" unless ref $options{sources} eq 'HASH'; + if ($options{aliases}) { + croak "aliases should be an hashref" unless ref $options{aliases} eq 'HASH'; + } + + foreach my $id (keys %{$options{sources}}) { + print "Creating source $id\n" if $options{verbose}; + eval { + # add global aliases if defined + if ($options{aliases}) { + foreach my $alias (keys %{$options{aliases}}) { + $options{sources}->{$id}->{aliases}->{$alias} = + $options{aliases}->{$alias} + } + } + + push( + @{$self->{_sources}}, + create_instance( + 'Youri::Check::Input::Updates::Source', + id => $id, + test => $options{test}, + verbose => $options{verbose}, + check_id => $options{id}, + resolver => $options{resolver}, + preferences => $options{preferences}, + %{$options{sources}->{$id}} + ) + ); + }; + print STDERR "Failed to create source $id: $@\n" if $@; + } + + croak "no sources created" unless @{$self->{_sources}}; +} + +sub run { + my ($self, $media, $resultset) = @_; + croak "Not a class method" unless ref $self; + + # this is a source media check only + return unless $media->get_type() eq 'source'; + + my $callback = sub { + my ($package) = @_; + + my $name = $package->get_name(); + my $version = $package->get_version(); + my $release = $package->get_release(); + + # compute version with rpm subtilities related to preversions + my $current_version = ($release =~ /^0\.(\w+)\.\w+$/) ? + $version . $1 : + $version; + my $current_stable = is_stable($current_version); + + my ($max_version, $max_source, $max_url); + $max_version = $current_version; + + foreach my $source (@{$self->{_sources}}) { + my $available_version = $source->get_version($package); + if ( + $available_version && + (! $current_stable || is_stable($available_version)) && + is_newer($available_version, $max_version) + ) { + $max_version = $available_version; + $max_source = $source->get_id(); + $max_url = $source->get_url($name); + } + } + $resultset->add_result($self->{_id}, $media, $package, { + current => $current_version, + available => $max_version, + source => $max_source, + url => $max_url + }) if $max_version ne $current_version; + }; + + $media->traverse_headers($callback); +} + +=head2 is_stable($version) + +Checks if given version is stable. + +=cut + +sub is_stable { + my ($version) = @_; + return $version !~ /alpha|beta|pre|rc|cvs|svn/i; + +} + +=head2 is_newer($v1, $v2) + +Checks if $v1 is newer than $v2. + +This function will return true only if we are sure this is newer (and not equal). +If we can't compare the versions, a warning will be displayed. + +=cut + +sub is_newer { + my ($v1, $v2) = @_; + return 0 if $v1 eq $v2; + + # Reject strange cases + # One is a large number (like date or revision) and the other one not, or + # has different length + if (($v1 =~ /^\d{3,}$/ || $v2 =~ /^\d{3,}$/) + && (join('0',split(/\d/, $v1."X")) ne join('0',split(/\d/, $v2."X")))) { + carp "strange : $v1 vs $v2"; + return 0; + } + + my %states = (alpha=>-4,beta=>-3,pre=>-2,rc=>-1); + my $i; $states{$_} = ++$i foreach 'a'..'z'; + + if ($v1 =~ /^[\d._-]+$/ && $v2 =~ /^[\d._-]+$/) { + my @v1 = split(/[._-]/, $v1); + my @v2 = split(/[._-]/, $v2); + if (join('',@v1) eq (join '',@v2)) { + # Might be something like 1.2.0 vs 1.20, usual false positive + carp "strange : $v1 vs $v2"; + return 0; + } + for my $i (0 .. $#v1) { + $v1[$i] ||= 0; + $v2[$i] ||= 0; + return 1 if $v1[$i] > $v2[$i]; + return 0 if $v1[$i] < $v2[$i]; + } + # When v2 is longer than v1 but start the same, v1 <= v2 + return 0; + } else { + my ($num1, $state1, $statenum1, $other1, $num2, $state2, $statenum2, $other2); + + if ($v1 =~ /^$VERSION_REGEXP$/io) { + ($num1, $state1, $statenum1, $other1) = ($1, "\L$2", $3, $4); + } else { + carp "unknown version format $v1"; + return 0; + } + + if ($v2 =~ /^$VERSION_REGEXP$/io) { + ($num2, $state2, $statenum2, $other2) = ($1, "\L$2", $3, $4); + } else { + carp "unknown version format $v2"; + return 0; + } + + # If we know the format of only one, there might be an issue, do nothing + + if (($other1 && ! $other2 )||(!$other1 && $other2 )) { + carp "can't compare $v1 vs $v2"; + return 0; + } + + return 1 if is_newer($num1, $num2); + return 0 unless $num1 eq $num2; + + # The numeric part is the same but not the end + + if ($state1 eq '') { + return 1 if $state2 =~ /^(alpha|beta|pre|rc)/; + return 0 if $state2 =~ /^([a-z]|pl)$/; + carp "unknown state format $state2"; + return 0; + } + + if ($state2 eq '') { + return 0 if $state1 =~ /^(alpha|beta|pre|rc)/; + return 1 if $state1 =~ /^([a-z]|pl)$/; + carp "unknown state format $state1"; + return 0; + } + + if ($state1 eq $state2) { + return 1 if is_newer($statenum1, $statenum2); + return 0 unless $statenum1 eq $statenum2; + # If everything is the same except this, just compare it + # as we have no idea on the format + return "$other1" gt "$other2"; + } + + my $s1 = 0; + my $s2 = 0; + $s1=$states{$state1} if exists $states{$state1}; + $s2=$states{$state2} if exists $states{$state2}; + return $s1>$s2 if ($s1 != 0 && $s2 != 0); + return 1 if $s1<0 && $state2 =~ /^([a-z]|pl)$/; + return 0 if $s2<0 && $state1 =~ /^([a-z]|pl)$/; + carp "unknown case $v1, $v2"; + return 0; + } +} + +=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/Updates/Source.pm b/lib/Youri/Check/Input/Updates/Source.pm new file mode 100644 index 0000000..e81d4d5 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source.pm @@ -0,0 +1,240 @@ +# $Id: Source.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source; + +=head1 NAME + +Youri::Check::Input::Updates::Source - Abstract updates source + +=head1 DESCRIPTION + +This abstract class defines the updates source interface for +L. + +=cut + +use warnings; +use strict; +use Carp; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates object. + +Generic parameters (subclasses may define additional ones): + +=over + +=item aliases $aliases + +Hash of package aliases. + +=back + +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 + aliases => undef, # aliases + resolver => undef, # maintainer resolver + preferences => undef, # maintainer preferences + check_id => '', # parent check id + @_ + ); + + if ($options{aliases}) { + croak "aliases should be an hashref" unless ref $options{aliases} eq 'HASH'; + } + if ($options{resolver}) { + croak "resolver should be a Youri::Check::Maintainer::Resolver object" unless $options{resolver}->isa("Youri::Check::Maintainer::Resolver"); + } + if ($options{preferences}) { + croak "preferences should be a Youri::Check::Maintainer::Preferences object" unless $options{preferences}->isa("Youri::Check::Maintainer::Preferences"); + } + + my $self = bless { + _id => $options{id}, + _test => $options{test}, + _verbose => $options{verbose}, + _aliases => $options{aliases}, + _resolver => $options{resolver}, + _preferences => $options{preferences}, + _check_id => $options{check_id}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head1 INSTANCE METHODS + +Excepted explicit statement, package name is expressed with Mandriva naming +conventions. + +=head2 get_id() + +Returns source identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=head2 get_version($package) + +Returns available version for given package, which can be either a full +L object or just a package name. + +=cut + +sub get_version { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + my $name = ref $package && $package->isa('Youri::Package') ? + $package->get_canonical_name() : + $package; + + # translate in grabber namespace + $name = $self->get_name($name); + + # return if aliased to null + return unless $name; + + # return subclass computation + return $self->_version($name); +} + +=head2 get_url($name) + +Returns the URL of information source for package with given name. + +=cut + +sub get_url { + my ($self, $name) = @_; + + # retun subclass computation + return $self->_url($self->get_name($name)); +} + +=head2 name($name) + +Returns name converted to specific source naming conventions for package with given name. + +=cut + +sub get_name { + my ($self, $name) = @_; + croak "Not a class method" unless ref $self; + + # return config aliases if it exists + if ($self->{_aliases} ) { + return $self->{_aliases}->{$name} if exists $self->{_aliases}->{$name}; + } + + # return maintainer aliases if it exists + if ($self->{_resolver} && $self->{_preferences}) { + my $maintainer = $self->{_resolver}->get_maintainer($name); + if ($maintainer) { + my $aliases = $self->{_preferences}->get_preference( + $maintainer, + $self->{_check_id}, + 'aliases' + ); + if ($aliases) { + if ($aliases->{all}) { + return $aliases->{all}->{$name} if exists $aliases->{all}->{$name}; + } + if ($aliases->{$self->{_id}}) { + return $aliases->{$self->{_id}}->{$name} if exists $aliases->{$self->{_id}}->{$name}; + } + } + } + } + + # return return subclass computation + return $self->_name($name); +} + +=head2 _version($name) + +Hook called by default B implementation after name translation. + +=cut + +sub _version { + my ($self, $name) = @_; + return $self->{_versions}->{$name}; +} + +=head2 _url($name) + +Hook called by default B implementation after name translation. + +=cut + +sub _url { + my ($self, $name) = @_; + return undef; +} + +=head2 _name($name) + +Hook called by default B implementation if given name was not found in +the aliases. + +=cut + +sub _name { + my ($self, $name) = @_; + return $name; +} + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item version + +As an alternative, the B<_version()> hook can be implemented. + +=item url + +As an alternative, the <_url()> hook can be implemented. + +=item name + +As an alternative, the B<_name()> hook can be implemented. + +=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/Updates/Source/CPAN.pm b/lib/Youri/Check/Input/Updates/Source/CPAN.pm new file mode 100644 index 0000000..cff1d29 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/CPAN.pm @@ -0,0 +1,75 @@ +# $Id: CPAN.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::CPAN; + +=head1 NAME + +Youri::Check::Input::Updates::Source::CPAN - CPAN updates source + +=head1 DESCRIPTION + +This source plugin for L collects updates +available from CPAN. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::CPAN object. + +Specific parameters: + +=over + +=item url $url + +URL to CPAN full modules list (default: +http://www.cpan.org/modules/01modules.index.html) + +=back + +=cut + + +sub _init { + my $self = shift; + my %options = ( + url => 'http://www.cpan.org/modules/01modules.index.html', + @_ + ); + + my $versions; + open(INPUT, "GET $options{url} |") or croak "Can't fetch $options{url}: $!"; + while () { + next unless $_ =~ />([\w-]+)-([\d\.]+)\.tar\.gz<\/a>/; + $versions->{$1} = $2; + } + close(INPUT); + + $self->{_versions} = $versions; +} + +sub _url { + my ($self, $name) = @_; + return "http://search.cpan.org/dist/$name"; +} + +sub _name { + my ($self, $name) = @_; + $name =~ s/^perl-//g; + return $name; +} + +=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/Updates/Source/Debian.pm b/lib/Youri/Check/Input/Updates/Source/Debian.pm new file mode 100644 index 0000000..24582a9 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Debian.pm @@ -0,0 +1,82 @@ +# $Id: Debian.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::Debian; + +=head1 NAME + +Youri::Check::Input::Updates::Source::Debian - Debian source for updates + +=head1 DESCRIPTION + +This source plugin for L collects updates + available from Debian. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::Debian object. + +Specific parameters: + +=over + +=item url $url + +URL to Debian mirror content file (default: http://ftp.debian.org/ls-lR.gz) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + url => 'http://ftp.debian.org/ls-lR.gz', + @_ + ); + + my $versions; + open(INPUT, "GET $options{url} | zcat |") or croak "Can't fetch $options{url}: $!"; + while (my $line = ) { + next unless $line =~ /([\w\.-]+)_([\d\.]+)\.orig\.tar\.gz$/; + my $name = $1; + my $version = $2; + $versions->{$name} = $version; + } + close(INPUT); + + $self->{_versions} = $versions; +} + +sub _url { + my ($self, $name) = @_; + return "http://packages.debian.org/$name"; +} + +sub _name { + my ($self, $name) = @_; + + if ($name =~ /^(perl|ruby)-([-\w]+)$/) { + $name = lc("lib$2-$1"); + } elsif ($name =~ /^apache-([-\w]+)$/) { + $name = "libapache-$1"; + $name =~ s/_/-/g; + } + + return $name; +} + +=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/Updates/Source/Fedora.pm b/lib/Youri/Check/Input/Updates/Source/Fedora.pm new file mode 100644 index 0000000..cb74d36 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Fedora.pm @@ -0,0 +1,63 @@ +# $Id: Fedora.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::Fedora; + +=head1 NAME + +Youri::Check::Input::Updates::Source::Fedora - Fedora updates source + +=head1 DESCRIPTION + +This source plugin for L collects updates +available from Fedora. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::Fedora object. + +Specific parameters: + +=over + +=item url $url + +URL to Fedora development SRPMS directory (default: +http://fr.rpmfind.net/linux/fedora/core/development/SRPMS) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + url => 'http://fr.rpmfind.net/linux/fedora/core/development/SRPMS', + @_ + ); + + my $versions; + open(INPUT, "GET $options{url} |") or die "Can't fetch $options{url}: $!\n"; + while () { + next unless $_ =~ />([\w-]+)-([\w\.]+)-[\w\.]+\.src\.rpm<\/a>/; + $versions->{$1} = $2; + } + close(INPUT); + + $self->{_versions} = $versions; +} + +=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/Updates/Source/Freshmeat.pm b/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm new file mode 100644 index 0000000..9e9b7ce --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm @@ -0,0 +1,111 @@ +# $Id: Freshmeat.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::Freshmeat; + +=head1 NAME + +Youri::Check::Input::Updates::Source::Freshmeat - Freshmeat source for updates + +=head1 DESCRIPTION + +This source plugin for L collects updates +available from Freshmeat. + +=cut + +use warnings; +use strict; +use Carp; +use XML::Twig; +use LWP::UserAgent; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::Freshmeat +object. + +Specific parameters: + +=over + +=item preload true/false + +Allows to load full Freshmeat catalogue at once instead of checking each software independantly (default: false) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + preload => 0, + @_ + ); + + if ($options{preload}) { + my $versions; + + my $project = sub { + my ($twig, $project) = @_; + my $name = $project->first_child('projectname_short')->text(); + my $version = $project->first_child('latest_release')->first_child('latest_release_version')->text(); + $versions->{$name} = $version; + $twig->purge(); + }; + + my $twig = XML::Twig->new( + TwigRoots => { project => $project } + ); + + my $url = 'http://download.freshmeat.net/backend/fm-projects.rdf.bz2'; + + open(INPUT, "GET $url | bzcat |") or die "Can't fetch $url: $!\n"; + $twig->parse(\*INPUT); + close(INPUT); + + $self->{_versions} = $versions; + } +} + +sub _version { + my ($self, $name) = @_; + + if ($self->{_versions}) { + return $self->{_versions}->{$name}; + } else { + my $version; + + my $latest_release_version = sub { + $version = $_[1]->text(); + }; + + my $twig = XML::Twig->new( + TwigRoots => { latest_release_version => $latest_release_version } + ); + + my $url = "http://freshmeat.net/projects-xml/$name"; + + open(INPUT, "GET $url |") or die "Can't fetch $url: $!\n"; + # freshmeat answer with an HTML page when project doesn't exist + $twig->safe_parse(\*INPUT); + close(INPUT); + + return $version; + } +} + +sub _url { + my ($self, $name) = @_; + return "http://freshmeat.net/projects/$name"; +} + +=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/Updates/Source/GNOME.pm b/lib/Youri/Check/Input/Updates/Source/GNOME.pm new file mode 100644 index 0000000..381ae5e --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/GNOME.pm @@ -0,0 +1,104 @@ +# $Id$ +package Youri::Check::Input::Updates::Source::GNOME; + +=head1 NAME + +Youri::Check::Input::Updates::Source::GNOME - GNOME updates source + +=head1 DESCRIPTION + +This source plugin for L collects updates +available from GNOME. + +=cut + +use warnings; +use strict; +use Carp; +use LWP::UserAgent; +use HTML::TokeParser; +use List::MoreUtils 'any'; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::Gnome object. + +Specific parameters: + +=over + +=item url $url + +URL to GNOME sources directory (default: +http://fr2.rpmfind.net/linux/gnome.org/sources) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + url => 'http://fr2.rpmfind.net/linux/gnome.org/sources/', # default url + # We use HTTP as it offers a better sorting (1.2 < 1.10) + @_ + ); + + $self->{_agent} = LWP::UserAgent->new(); + my $response = $self->{_agent}->get($options{url}); + 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 =~ /^([-\w]+)\/$/o; + $self->{_names}->{$1} = 1; + } + } + + $self->{_url} = $options{url}; +} + +sub _version { + my ($self, $name) = @_; + croak "Not a class method" unless ref $self; + + return unless $self->{_names}->{$name}; + + my $response = $self->{_agent}->get("$self->{_url}/$name/"); + if($response->is_success()) { + my $major; + my $parser = HTML::TokeParser->new(\$response->content()); + while (my $token = $parser->get_tag('a')) { + my $href = $token->[1]->{href}; + next unless $href =~ /^([.\d]+)\/$/o; + $major = $1; + } + return unless $major; + + $response = $self->{_agent}->get("$self->{_url}/$name/$major/"); + if($response->is_success()) { + $parser = HTML::TokeParser->new(\$response->content()); + while (my $token = $parser->get_tag('a')) { + my $href = $token->[1]->{href}; + next unless $href =~ /^LATEST-IS-([.\d]+)$/o; + return $1; + } + } + } +} + +sub _url { + my ($self, $name) = @_; + return $self->{_url}."$name/"; +} + +=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/Updates/Source/Gentoo.pm b/lib/Youri/Check/Input/Updates/Source/Gentoo.pm new file mode 100644 index 0000000..de8f376 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Gentoo.pm @@ -0,0 +1,75 @@ +# $Id: Gentoo.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::Gentoo; + +=head1 NAME + +Youri::Check::Input::Updates::Source::Gentoo - Gentoo updates source + +=head1 DESCRIPTION + +This source plugin for L collects updates +available from Gentoo. + +=cut + +use warnings; +use strict; +use Carp; +use LWP::Simple; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::Gentoo object. + +Specific parameters: + +=over + +=item url $url + +URL to Gentoo snapshots directory (default: +http://gentoo.mirror.sdv.fr/snapshots) + +=back + +=cut + + +sub _init { + my $self = shift; + my %options = ( + url => 'http://gentoo.mirror.sdv.fr/snapshots', # default URL + @_ + ); + + my $versions; + my $content = get($options{url}); + my $file; + while ($content =~ //g) { + $file = $1; + } + open(INPUT, "GET $options{url}/$file | tar tjf - |") or croak "Can't fetch $options{url}/$file: $!"; + while (my $line = ) { + next unless $line =~ /.*\/([\w-]+)-([\d\.]+)(:?-r\d)?\.ebuild$/; + $versions->{$1} = $2; + } + close(INPUT); + + $self->{_versions} = $versions; +} + +sub _url { + my ($self, $name) = @_; + return "http://packages.gentoo.org/search/?sstring=$name"; +} + +=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/Updates/Source/NetBSD.pm b/lib/Youri/Check/Input/Updates/Source/NetBSD.pm new file mode 100644 index 0000000..5142001 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/NetBSD.pm @@ -0,0 +1,75 @@ +# $Id$ +package Youri::Check::Input::Updates::Source::NetBSD; + +=head1 NAME + +Youri::Check::Input::Updates::Source::NetBSD - NetBSD source for updates + +=head1 DESCRIPTION + +This source plugin for L collects updates + available from NetBSD. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Input::Updates::Source'; +use IO::Ftp; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::NetBSD object. + +Specific parameters: + +=over + +=item url $url + +URL to NetBSD mirror content file, without ftp: (default: //ftp.free.fr/mirrors/ftp.netbsd.org/NetBSD-current/pkgsrc/README-all.html) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + url => '//ftp.free.fr/mirrors/ftp.netbsd.org/NetBSD-current/pkgsrc/README-all.html', + @_ + ); + + my $versions; + my $urls; + + my $in = IO::Ftp->new('<',$options{url}) or croak "Can't fetch $options{url}: $!"; + while (my $line = <$in>) { + next unless $line =~ /