diff options
Diffstat (limited to 'lib/Youri/Check/Input')
23 files changed, 2800 insertions, 0 deletions
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<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; 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 (<RPMLINT>) { + 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<Youri::Check::Input::Updates>. + +=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<Youri::Package> 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<version()> implementation after name translation. + +=cut + +sub _version { + my ($self, $name) = @_; + return $self->{_versions}->{$name}; +} + +=head2 _url($name) + +Hook called by default B<url()> implementation after name translation. + +=cut + +sub _url { + my ($self, $name) = @_; + return undef; +} + +=head2 _name($name) + +Hook called by default B<name()> 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<Youri::Check::Input::Updates> 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 (<INPUT>) { + 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<Youri::Check::Input::Updates> 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 = <INPUT>) { + 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<Youri::Check::Input::Updates> 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 (<INPUT>) { + 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<Youri::Check::Input::Updates> 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<Youri::Check::Input::Updates> 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<Youri::Check::Input::Updates> 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 =~ /<A HREF="(portage-\d{8}.tar.bz2)">/g) { + $file = $1; + } + open(INPUT, "GET $options{url}/$file | tar tjf - |") or croak "Can't fetch $options{url}/$file: $!"; + while (my $line = <INPUT>) { + 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<Youri::Check::Input::Updates> 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 =~ /<!-- (.+)-([^-]*?)(nb\d*)? \(for sorting\).*?href="([^"]+)"/; + my $name = $1; + my $version = $2; + $versions->{$name} = $version; + $urls->{$name} = $4; + } + close($in); + + $self->{_versions} = $versions; + $self->{_urls} = $urls; + $self->{_url} = $options{url}; +} + +sub _url { + my ($self, $name) = @_; + return $self->{_urls}->{$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/RAA.pm b/lib/Youri/Check/Input/Updates/Source/RAA.pm new file mode 100644 index 0000000..2e7356e --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/RAA.pm @@ -0,0 +1,121 @@ +# $Id: RAA.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::RAA; + +=head1 NAME + +Youri::Check::Input::Updates::Source::RAA - RAA updates source + +=head1 DESCRIPTION + +This source plugin for L<Youri::Check::Input::Updates> collects updates +available from RAA. + +=cut + +use warnings; +use strict; +use Carp; +use SOAP::Lite; +use List::MoreUtils 'any'; +use Youri::Package; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::RAA object. + +Specific parameters: + +=over + +=item url $url + +URL to RAA SOAP interface (default: +http://www.ruby-lang.org/xmlns/soap/interface/RAA/0.0.4) + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + url => 'http://www.ruby-lang.org/xmlns/soap/interface/RAA/0.0.4/', + @_ + ); + + my $raa = SOAP::Lite->service($options{url}) + or croak "Can't connect to $options{url}"; + + $self->{_raa} = $raa; + $self->{_names} = $raa->names(); +} + +sub get_version { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + my $name; + if (ref $package && $package->isa('Youri::Package')) { + # don't bother checking for non-ruby packages + if ( + any { $_->[Youri::Package::DEPENDENCY_NAME] =~ /ruby/ } + $package->get_requires() + ) { + $name = $package->get_canonical_name(); + } else { + return; + } + } else { + $name = $package; + } + + # translate in grabber namespace + $name = $self->get_name($name); + + # return if aliased to null + return unless $name; + + # susceptible to throw exception for timeout + eval { + my $gem = $self->{_raa}->gem($name); + return $gem->{project}->{version} if $gem; + }; + + return; +} + +sub _url { + my ($self, $name) = @_; + return "http://raa.ruby-lang.org/project/$name/"; +} + +sub _name { + my ($self, $name) = @_; + + if (ref $self) { + my $match = $name; + $match =~ s/^ruby[-_]//; + $match =~ s/[-_]ruby$//; + my @results = + grep { /^(ruby[-_])?\Q$match\E([-_]ruby)$/ } + @{$self->{_names}}; + if (@results) { + return $results[0]; + } else { + return $name; + } + } else { + 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/Sourceforge.pm b/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm new file mode 100644 index 0000000..7623b3b --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm @@ -0,0 +1,103 @@ +# $Id: Sourceforge.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input::Updates::Source::Sourceforge; + +=head1 NAME + +Youri::Check::Input::Updates::Source::Sourceforge - Sourceforge updates source + +=head1 DESCRIPTION + +This source plugin for L<Youri::Check::Input::Updates> collects updates +available from Sourceforge. + +=cut + +use warnings; +use strict; +use Carp; +use LWP::UserAgent; +use HTML::TokeParser; +use Youri::Check::Input::Updates; +use base 'Youri::Check::Input::Updates::Source'; + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input::Updates::Source::Sourceforge +object. + +No specific parameters. + +=cut + +sub _init { + my $self = shift; + my %options = ( + @_ + ); + + $self->{_agent} = LWP::UserAgent->new(); +} + +sub get_version { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + my $name; + if (ref $package && $package->isa('Youri::Package')) { + # don't bother checking for packages without sf.net URL + my $url = $package->get_url(); + if ( + $url =~ /http:\/\/(.*)\.sourceforge\.net/ || + $url =~ /http:\/\/.*sourceforge\.net\/projects\/([^\/]+)/ + ) { + $name = $package->get_canonical_name(); + } else { + return; + } + } else { + $name = $package; + } + + # translate in grabber namespace + $name = $self->get_name($name); + + # return if aliased to null + return unless $name; + + my $response = $self->{_agent}->get($self->_url($name)); + if($response->is_success()) { + my $max = 0; + my $parser = HTML::TokeParser->new(\$response->content()); + while (my $token = $parser->get_tag('a')) { + my $text = $parser->get_trimmed_text("/$token->[0]"); + next unless $text; + next unless $text =~ /^ + \Q$name\E + [._-]?($Youri::Check::Input::Updates::VERSION_REGEXP) + [._-]?(w(?:in)?(?:32)?|mips|sparc|bin|ppc|i\d86|src|sources?)? + \.(?:tar\.(?:gz|bz2)|tgz|zip) + $/iox; + my $version = $1; + my $arch = $2; + next if $arch && $arch !~ /(src|sources?)/; + $max = $version if Youri::Check::Input::Updates::is_newer($version, $max); + } + return $max if $max; + } + return; +} + +sub _url { + my ($self, $name) = @_; + return "http://prdownloads.sourceforge.net/$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; |