diff options
Diffstat (limited to 'lib/Youri/Check')
42 files changed, 5162 insertions, 0 deletions
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 +<Youri::Media> objects. + +=cut + +sub prepare { + # do nothing +} + +=head2 run($media, $resultset) + +Check the packages from given L<Youri::Media> object, and store the +result in given L<Youri::Check::Resultset> 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<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; diff --git a/lib/Youri/Check/Maintainer/Preferences.pm b/lib/Youri/Check/Maintainer/Preferences.pm new file mode 100644 index 0000000..5fbe203 --- /dev/null +++ b/lib/Youri/Check/Maintainer/Preferences.pm @@ -0,0 +1,80 @@ +# $Id: Preferences.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Maintainer::Preferences; + +=head1 NAME + +Youri::Check::Maintainer::Preferences - Abstract maintainer preferences + +=head1 DESCRIPTION + +This abstract class defines Youri::Check::Maintainer::Preferences interface. + +=head1 SYNOPSIS + + use Youri::Check::Maintainer::Preferences::Foo; + + my $preferences = Youri::Check::Maintainer::Preferences::Foo->new(); + +=cut + +use warnings; +use strict; +use Carp; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Maintainer::Preferences object. + +Warning: do not call directly, call subclass constructor instead. + +=cut + +sub new { + my $class = shift; + croak "Abstract class" if $class eq __PACKAGE__; + + my %options = ( + test => 0, # test mode + verbose => 0, # verbose mode + @_ + ); + + my $self = bless { + _test => $options{test}, + _verbose => $options{verbose}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head2 get_preference($maintainer, $plugin, $item) + +Returns preference of given maintainer for given plugin and configuration item. + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item get + +=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/Maintainer/Preferences/File.pm b/lib/Youri/Check/Maintainer/Preferences/File.pm new file mode 100644 index 0000000..223d56f --- /dev/null +++ b/lib/Youri/Check/Maintainer/Preferences/File.pm @@ -0,0 +1,87 @@ +# $Id: File.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Maintainer::Preferences::File; + +=head1 NAME + +Youri::Check::Maintainer::Preferences::File - File-based maintainer preferences implementation + +=head1 DESCRIPTION + +This is a file-based L<Youri::Check::Maintainer::Preferences> implementation. + +It uses files in maintainer home directories. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Config; +use base 'Youri::Check::Maintainer::Preferences'; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Maintainer::Preferences::File object. + +No specific parameters. + +=cut + +sub get_preference { + my ($self, $maintainer, $plugin, $value) = @_; + croak "Not a class method" unless ref $self; + return unless $maintainer && $plugin && $value; + + print "Retrieving maintainer $maintainer preferences\n" + if $self->{_verbose} > 0; + + $self->_load_config($maintainer) + unless exists $self->{_config}->{$maintainer}; + + return $self->{_config}->{$maintainer} ? + $self->{_config}->{$maintainer}->get($plugin . '_' . $value) : + undef; +} + +sub _load_config { + my ($self, $maintainer) = @_; + + print "Attempting to load maintainers preferences for $maintainer\n" if $self->{_verbose} > 1; + + + my ($login) = $maintainer =~ /^(\S+)\@\S+$/; + my $home = (getpwnam($login))[7]; + my $file = "$home/.youri/check.prefs"; + + if (-f $file && -r $file) { + print "Found, loading\n" if $self->{_verbose} > 1; + my $config = Youri::Config->new( + { + CREATE => 1, + GLOBAL => { + DEFAULT => undef, + EXPAND => EXPAND_VAR | EXPAND_ENV, + ARGCOUNT => ARGCOUNT_ONE, + } + } + ); + $config->file($file); + $self->{_config}->{$maintainer} = $config; + } else { + print "Not found, aborting\n" if $self->{_verbose} > 1; + $self->{_config}->{$maintainer} = undef; + } + +} + +=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/Maintainer/Resolver.pm b/lib/Youri/Check/Maintainer/Resolver.pm new file mode 100644 index 0000000..bc720eb --- /dev/null +++ b/lib/Youri/Check/Maintainer/Resolver.pm @@ -0,0 +1,86 @@ +# $Id: Resolver.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Maintainer::Resolver; + +=head1 NAME + +Youri::Check::Maintainer::Resolver - Abstract maintainer resolver + +=head1 DESCRIPTION + +This abstract class defines Youri::Check::Maintainer::Resolver interface. + +=head1 SYNOPSIS + + use Youri::Check::Maintainer::Resolver::Foo; + + my $resolver = Youri::Check::Maintainer::Resolver::Foo->new(); + + print $resolver->get_maintainer('foo'); + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Utils; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Maintainer::Resolver 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 = ( + test => 0, # test mode + verbose => 0, # verbose mode + @_ + ); + + my $self = bless { + _test => $options{test}, + _verbose => $options{verbose} + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head2 get_maintainer($package) + +Returns maintainer for given package, which can be either a full +L<Youri::Package> object or just a package name. + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item get_maintainer + +=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/Maintainer/Resolver/Bugzilla.pm b/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm new file mode 100644 index 0000000..0cf13fc --- /dev/null +++ b/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm @@ -0,0 +1,100 @@ +# $Id: Bugzilla.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Maintainer::Resolver::Bugzilla; + +=head1 NAME + +Youri::Check::Maintainer::Resolver::Bugzilla - Bugzilla-based maintainer resolver + +=head1 DESCRIPTION + +This is a Bugzilla-based L<Youri::Check::Maintainer::Resolver> implementation. + +It uses Bugzilla SQL database for resolving maintainers. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Bugzilla; +use base 'Youri::Check::Maintainer::Resolver'; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Maintainer::Resolver::Bugzilla object. + +Specific parameters: + +=over + +=item host $host + +Bugzilla database host. + +=item base $base + +Bugzilla database name. + +=item user $user + +Bugzilla database user. + +=item pass $pass + +Bugzilla database password. + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + host => '', # host of the bug database + base => '', # name of the bug database + user => '', # user of the bug database + pass => '', # pass of the bug database + @_ + ); + + croak "No host given" unless $options{host}; + croak "No base given" unless $options{base}; + croak "No user given" unless $options{user}; + croak "No pass given" unless $options{pass}; + + my $bugzilla = Youri::Bugzilla->new( + $options{host}, + $options{base}, + $options{user}, + $options{pass} + ); + + $self->{_bugzilla} = $bugzilla; +} + +sub get_maintainer { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + my $name = ref $package && $package->isa('Youri::Package') ? + $package->get_canonical_name() : + $package; + + $self->{_maintainers}->{$name} = + $self->{_bugzilla}->get_maintainer($name) + unless exists $self->{_maintainers}->{$name}; + + return $self->{_maintainers}->{$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/Maintainer/Resolver/CGI.pm b/lib/Youri/Check/Maintainer/Resolver/CGI.pm new file mode 100644 index 0000000..21357b8 --- /dev/null +++ b/lib/Youri/Check/Maintainer/Resolver/CGI.pm @@ -0,0 +1,79 @@ +# $Id: CGI.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Maintainer::Resolver::CGI; + +=head1 NAME + +Youri::Check::Maintainer::Resolver::CGI - CGI-based maintainer resolver + +=head1 DESCRIPTION + +This is a CGI-based L<Youri::Check::Maintainer::Resolver> implementation. + +It uses a remote CGI to resolve maintainers. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Maintainer::Resolver'; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Maintainer::Resolver::CGI object. + +Specific parameters: + +=over + +=item url $url + +CGI's URL. + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + url => '', # url to fetch maintainers + @_ + ); + + croak "No URL given" unless $options{url}; + + open (INPUT, "GET $options{url} |"); + while (<INPUT>) { + chomp; + my ($package, $maintainer) = split(/\t/, $_); + $self->{_maintainers}->{$package} = $maintainer if $maintainer; + } + close(INPUT); +} + +sub get_maintainer { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + print "Retrieving package $package maintainer\n" + if $self->{_verbose} > 0; + + my $name = ref $package && $package->isa('Youri::Package') ? + $package->get_canonical_name() : + $package; + + return $self->{_maintainers}->{$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/Output.pm b/lib/Youri/Check/Output.pm new file mode 100644 index 0000000..d518a3b --- /dev/null +++ b/lib/Youri/Check/Output.pm @@ -0,0 +1,190 @@ +# $Id: Output.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Output; + +=head1 NAME + +Youri::Check::Output - Abstract output plugin + +=head1 DESCRIPTION + +This abstract class defines output plugin interface. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Utils; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Output object. + +Generic parameters (subclasses may define additional ones): + +=over + +=item global true/false + +Global reports generation (default: true). + +=item individual true/false + +Individual reports generation (default: true). + +=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 => '', + test => 0, + verbose => 0, + global => 1, + individual => 1, + config => undef, + @_ + ); + + croak "Neither global nor individual reporting selected" unless $options{global} || $options{individual}; + + my $self = bless { + _id => $options{id}, + _test => $options{test}, + _verbose => $options{verbose}, + _global => $options{global}, + _individual => $options{individual}, + _config => $options{config} + }, $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 run($resultset) + +Reports the result stored in given L<Youri::Check::Resultset> object. + +=cut + +sub run { + my ($self, $resultset) = @_; + + $self->_init_report(); + + # get types and maintainers list from resultset + my @maintainers = $resultset->get_maintainers(); + my @types = $resultset->get_types(); + + foreach my $type (@types) { + # get formatting instructions from class + my $class = $self->{_config}->get($type . '_class'); + load($class); + my @columns = $class->columns(); + my %links = $class->links(); + + if ($self->{_global}) { + print STDERR "generating global report for $type\n" if $self->{_verbose}; + $self->_global_report( + $resultset, + $type, + \@columns, + \%links + ); + } + + if ($self->{_individual}) { + foreach my $maintainer (@maintainers) { + print STDERR "generating individual report for $type and $maintainer\n" if $self->{_verbose}; + + $self->_individual_report( + $resultset, + $type, + \@columns, + \%links, + $maintainer + ); + } + } + } + + $self->_finish_report(\@types, \@maintainers); +} + +sub _init_report { + # do nothing +} + +sub _global_report { + # do nothing +} + +sub _individual_report { + # do nothing +} + +sub _finish_report { + # do nothing +} + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item run + +As an alternative, the following hooks can be implemented: + +=over + +=item _init_report + +=item _global_report + +=item _individual_report + +=item _finish_report + +=back + +=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/Output/File.pm b/lib/Youri/Check/Output/File.pm new file mode 100644 index 0000000..5363e8e --- /dev/null +++ b/lib/Youri/Check/Output/File.pm @@ -0,0 +1,203 @@ +# $Id: Text.pm 523 2005-10-11 08:36:49Z misc $ +package Youri::Check::Output::File; + +=head1 NAME + +Youri::Check::Output::File - Report results in files + +=head1 DESCRIPTION + +This plugin reports results in files. Additional subplugins handle specific +formats. + +=cut + +use warnings; +use strict; +use Carp; +use File::Basename; +use File::Path; +use DateTime; +use Youri::Utils; +use base 'Youri::Check::Output'; + +sub _init { + my $self = shift; + my %options = ( + to => '', # target directory + noclean => 0, # don't clean up target directory + noempty => 0, # don't generate empty reports + formats => undef, + @_ + ); + + croak "no format defined" unless $options{formats}; + croak "formats should be an hashref" unless ref $options{formats} eq 'HASH'; + + my $now = DateTime->now(time_zone => 'local'); + my $time = "the " . $now->ymd() . " at " . $now->hms(); + + $self->{_to} = $options{to}; + $self->{_noclean} = $options{noclean}; + $self->{_noempty} = $options{noempty}; + $self->{_time} = $time; + + foreach my $id (keys %{$options{formats}}) { + print "Creating format $id\n" if $options{verbose}; + eval { + push( + @{$self->{_formats}}, + create_instance( + 'Youri::Check::Output::File::Format', + id => $id, + test => $options{test}, + verbose => $options{verbose}, + %{$options{formats}->{$id}} + ) + ); + }; + print STDERR "Failed to create format $id: $@\n" if $@; + } + + croak "no formats created" unless @{$self->{_formats}}; +} + +sub _init_report { + my ($self) = @_; + + # clean up output directory + unless ($self->{_test} || $self->{_noclean} || !$self->{_to}) { + my @files = glob($self->{_to} . '/*'); + rmtree(\@files) if @files; + } +} + +sub _global_report { + my ($self, $resultset, $type, $columns, $links) = @_; + + foreach my $format (@{$self->{_formats}}) { + my $iterator = $resultset->get_iterator( + $type, + [ 'package' ] + ); + + return if $self->{_noempty} && ! $iterator->has_results(); + + my $content = $format->get_report( + $self->{_time}, + "$type global report", + $iterator, + $type, + $columns, + $links, + undef + ); + + # create and register file + my $extension = $format->extension(); + $self->_write_file( + "$self->{_to}/$type.$extension", + $content + ); + push( + @{$self->{_files}->{global}->{$type}}, + $extension + ); + } +} + +sub _individual_report { + my ($self, $resultset, $type, $columns, $links, $maintainer) = @_; + + foreach my $format (@{$self->{_formats}}) { + my $iterator = $resultset->get_iterator( + $type, + [ 'package' ], + { maintainer => [ $maintainer ] } + ); + + return if $self->{_noempty} && ! $iterator->has_results(); + + my $content = $format->get_report( + $self->{_time}, + "$type individual report for $maintainer", + $iterator, + $type, + $columns, + $links, + $maintainer + ); + + # create and register file + my $extension = $format->extension(); + $self->_write_file( + "$self->{_to}/$maintainer/$type.$extension", + $content + ); + push( + @{$self->{_files}->{maintainers}->{$maintainer}->{$type}}, + $extension + ); + } +} + +sub _finish_report { + my ($self, $types, $maintainers) = @_; + + foreach my $format (@{$self->{_formats}}) { + next unless $format->can('get_index'); + my $extension = $format->extension(); + print STDERR "writing global index page\n" if $self->{_verbose}; + $self->_write_file( + "$self->{_to}/index.$extension", + $format->get_index( + $self->{_time}, + "QA global report", + $self->{_files}->{global}, + [ keys %{$self->{_files}->{maintainers}} ], + ) + ); + foreach my $maintainer (@$maintainers) { + print STDERR "writing index page for $maintainer\n" if $self->{_verbose}; + + $self->_write_file( + "$self->{_to}/$maintainer/index.$extension", + $format->get_index( + $self->{_time}, + "QA report for $maintainer", + $self->{_files}->{maintainers}->{$maintainer}, + undef, + ) + ); + } + } +} + +sub _write_file { + my ($self, $file, $content) = @_; + + return unless $content; + + my $dirname = dirname($file); + mkpath($dirname) unless -d $dirname; + + if ($self->{_test}) { + *OUT = *STDOUT; + } else { + open(OUT, ">$file") or die "Can't open file $file: $!"; + } + + print OUT $$content; + + close(OUT) unless $self->{_test}; +} + +=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/Output/File/Format.pm b/lib/Youri/Check/Output/File/Format.pm new file mode 100644 index 0000000..c91a28b --- /dev/null +++ b/lib/Youri/Check/Output/File/Format.pm @@ -0,0 +1,66 @@ +# $Id: Base.pm 579 2006-01-09 21:17:54Z guillomovitch $ +package Youri::Check::Output::File::Format; + +=head1 NAME + +Youri::Check::Output::File::Format - Abstract file format support + +=head1 DESCRIPTION + +This abstract class defines the format support interface for +L<Youri::Check::Output::File>. + +=cut + +use warnings; +use strict; +use Carp; + +sub new { + my $class = shift; + croak "Abstract class" if $class eq __PACKAGE__; + + my %options = ( + id => '', + test => 0, + verbose => 0, + @_ + ); + + my $self = bless { + _id => $options{id}, + _test => $options{test}, + _verbose => $options{verbose}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head2 get_id() + +Returns format handler identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=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/Output/File/Format/HTML.pm b/lib/Youri/Check/Output/File/Format/HTML.pm new file mode 100644 index 0000000..c498bbd --- /dev/null +++ b/lib/Youri/Check/Output/File/Format/HTML.pm @@ -0,0 +1,222 @@ +# $Id: HTML.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Output::File::Format::HTML; + +=head1 NAME + +Youri::Check::Output::File::Format::HTML - File HTML format support + +=head1 DESCRIPTION + +This format plugin for L<Youri::Check::Output::File> provides HTML format +support. + +=cut + +use warnings; +use strict; +use Carp; +use CGI; +use base 'Youri::Check::Output::File::Format'; + +sub extension { + return 'html'; +} + +sub _init { + my $self = shift; + my %options = ( + style => <<EOF, # css style +h1 { + text-align:center; +} +table { + border-style:solid; + border-width:1px; + border-color:black; + width:100%; +} +tr.odd { + background-color:white; +} +tr.even { + background-color:silver; +} +p.footer { + font-size:smaller; + text-align:center; +} +EOF + @_ + ); + + $self->{_style} = $options{style}; + $self->{_cgi} = CGI->new(); +} + +sub get_report { + my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_; + + my $content; + my $lead_columns = [ + $maintainer ? + qw/package media/ : + qw/package media maintainer/ + ]; + my $line; + my @results; + $content .= $self->{_cgi}->start_table(); + $content .= $self->{_cgi}->Tr([ + $self->{_cgi}->th([ + @$lead_columns, + @$columns + ]) + ]); + while (my $result = $iterator->get_result()) { + if (@results && $result->{package} ne $results[0]->{package}) { + $content .= $self->_get_formated_results( + $lead_columns, + $columns, + $links, + $line++ % 2 ? 'odd' : 'even', + \@results + ); + @results = (); + } + push(@results, $result); + } + $content .= $self->_get_formated_results( + $lead_columns, + $columns, + $links, + $line++ % 2 ? 'odd' : 'even', + \@results + ); + $content .= $self->{_cgi}->end_table(); + + return $self->_get_html_page($time, $title, \$content); +} + +sub get_index { + my ($self, $time, $title, $reports, $maintainers) = @_; + + my $content; + + if ($reports) { + $content .= $self->{_cgi}->h2("Reports"); + my @types = keys %{$reports}; + + $content .= $self->{_cgi}->start_ul(); + foreach my $type (sort @types) { + my $item; + $item = $self->{_cgi}->a( + { href => "$type.html" }, + $type + ); + foreach my $extension (@{$reports->{$type}}) { + next if ($extension eq extension()); + $item .= " ".$self->{_cgi}->a( + { href => "$type.$extension" }, + "[$extension]" + ); + } + $content .= $self->{_cgi}->li($item); + } + $content .= $self->{_cgi}->end_ul(); + } + + if ($maintainers) { + $content .= $self->{_cgi}->h2("Individual reports"); + + $content .= $self->{_cgi}->start_ul(); + foreach my $maintainer (sort @{$maintainers}) { + $content .= $self->{_cgi}->li( + $self->{_cgi}->a( + { href => "$maintainer/index.html" }, + _obfuscate($maintainer) + ) + ); + } + $content .= $self->{_cgi}->end_ul(); + } + + return $self->_get_html_page($time, $title, \$content); +} + +sub _get_formated_results { + my ($self, $lead_columns, $columns, $links, $class, $results) = @_; + + my $content; + $content .= $self->{_cgi}->end_Tr(); + for my $i (0 .. $#$results) { + $content .= $self->{_cgi}->start_Tr( + { class => $class } + ); + if ($i == 0) { + # first line contains spanned cells + $content .= $self->{_cgi}->td( + { rowspan => scalar @$results }, + [ + map { $results->[$i]->{$_} } + @$lead_columns + ] + ); + } + $content .= $self->{_cgi}->td( + [ + map { + $links->{$_} && $results->[$i]->{$links->{$_}} ? + $self->{_cgi}->a( + { href => $results->[$i]->{$links->{$_}} }, + $self->{_cgi}->escapeHTML($results->[$i]->{$_}) + ) : + $self->{_cgi}->escapeHTML($results->[$i]->{$_}) + } @$columns + ] + ); + $content .= $self->{_cgi}->end_Tr(); + } + + return $content; +} + + +sub _get_html_page { + my ($self, $time, $title, $body) = @_; + + my $content; + $content .= $self->{_cgi}->start_html( + -title => $title, + -style => { code => $self->{_style} } + ); + $content .= $self->{_cgi}->h1($title); + $content .= $$body; + $content .= $self->{_cgi}->hr(); + $content .= $self->{_cgi}->p( + { class => 'footer' }, + "Page generated $time" + ); + $content .= $self->{_cgi}->end_html(); + + return \$content; +} + +sub _obfuscate { + my ($email) = @_; + + return unless $email; + + $email =~ s/\@/ at /; + $email =~ s/\./ dot /; + + return $email; +} + +=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/Output/File/Format/RSS.pm b/lib/Youri/Check/Output/File/Format/RSS.pm new file mode 100644 index 0000000..66ffc61 --- /dev/null +++ b/lib/Youri/Check/Output/File/Format/RSS.pm @@ -0,0 +1,68 @@ +# $Id$ +package Youri::Check::Output::File::Format::RSS; + +=head1 NAME + +Youri::Check::Output::File::Format::RSS - File RSS format support + +=head1 DESCRIPTION + +This format plugin for L<Youri::Check::Output::File> provides RSS format +support. + +=cut + +use warnings; +use strict; +use Carp; +use XML::RSS; +use base 'Youri::Check::Output::File::Format'; + +sub extension { + return 'rss'; +} + +sub get_report { + my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_; + + return unless $maintainer; + + my $rss = new XML::RSS (version => '2.0'); + $rss->channel( + title => $title, + description => $title, + language => 'en', + ttl => 1440 + ); + + while (my $result = $iterator->get_result()) { + if ($type eq 'updates') { + $rss->add_item( + title => "$result->{package} $result->{available} is available", + description => "Current version is $result->{current}", + link => $result->{url} ? + $result->{url} : $result->{source}, + guid => "$result->{package}-$result->{available}" + ); + } else { + $rss->add_item( + title => "[$type] $result->{package}", + description => join("\n", (map { $result->{$_} || '' } @$columns)), + link => $result->{url}, + guid => "$type-$result->{package}" + ); + } + } + + return \$rss->as_string(); +} + +=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/Output/File/Format/Text.pm b/lib/Youri/Check/Output/File/Format/Text.pm new file mode 100644 index 0000000..d9f774d --- /dev/null +++ b/lib/Youri/Check/Output/File/Format/Text.pm @@ -0,0 +1,88 @@ +# $Id: Text.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Output::File::Format::Text; + +=head1 NAME + +Youri::Check::Output::File::Format::Text - File text format support + +=head1 DESCRIPTION + +This format plugin for L<Youri::Check::Output::File> provides text format +support. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Output::File::Format'; + +sub extension { + return 'txt'; +} + +sub get_report { + my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_; + + my $content; + $content .= $title; + $content .= "\n"; + + my $lead_columns = [ + $maintainer ? + qw/package media/ : + qw/package media maintainer/ + ]; + my @results; + $content .= join("\t", @$lead_columns, @$columns) . "\n"; + while (my $result = $iterator->get_result()) { + if (@results && $result->{package} ne $results[0]->{package}) { + $content .= $self->_get_formated_results( + $lead_columns, + $columns, + \@results + ); + @results = (); + } + push(@results, $result); + } + $content .= $self->_get_formated_results( + $lead_columns, + $columns, + \@results + ); + + $content .= "\n"; + $content .= "Page generated $time\n"; + + return \$content; +} + +sub _get_formated_results { + my ($self, $lead_columns, $columns, $results) = @_; + + my $content; + $content .= join( + "\t", + (map { $results->[0]->{$_} || '' } @$lead_columns), + (map { $results->[0]->{$_} || '' } @$columns) + ) . "\n"; + for my $i (1 .. $#$results) { + $content .= join( + "\t", + (map { '' } @$lead_columns), + (map { $results->[$i]->{$_} || '' } @$columns) + ) . "\n"; + } + return $content; +} + +=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/Output/Mail.pm b/lib/Youri/Check/Output/Mail.pm new file mode 100644 index 0000000..eb9a1f2 --- /dev/null +++ b/lib/Youri/Check/Output/Mail.pm @@ -0,0 +1,156 @@ +# $Id: Mail.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Output::Mail; + +=head1 NAME + +Youri::Check::Output::Mail - Report results by mail + +=head1 DESCRIPTION + +This plugin reports results by mail. Additional subplugins handle specific +formats. + +=cut + +use warnings; +use strict; +use Carp; +use MIME::Entity; +use Youri::Utils; +use base 'Youri::Check::Output'; + +sub _init { + my $self = shift; + my %options = ( + from => '', # mail from header + to => '', # mail to header + reply_to => '', # mail reply-to header + mta => '', # mta path + noempty => 1, # don't generate empty reports + formats => {}, + @_ + ); + + croak "no format defined" unless $options{formats}; + croak "formats should be an hashref" unless ref $options{formats} eq 'HASH'; + + $self->{_from} = $options{from}; + $self->{_to} = $options{to}; + $self->{_reply_to} = $options{reply_to}; + $self->{_mta} = $options{mta}; + $self->{_noempty} = $options{noempty}; + + foreach my $id (keys %{$options{formats}}) { + print "Creating format $id\n" if $options{verbose}; + eval { + push( + @{$self->{_formats}}, + create_instance( + 'Youri::Check::Output::Mail::Format', + id => $id, + test => $options{test}, + verbose => $options{verbose}, + %{$options{formats}->{$id}} + ) + ); + }; + print STDERR "Failed to create format $id: $@\n" if $@; + } + + croak "no formats created" unless @{$self->{_formats}}; +} + +sub _global_report { + my ($self, $resultset, $type, $columns, $links) = @_; + + foreach my $format (@{$self->{_formats}}) { + my $iterator = $resultset->get_iterator( + $type, + [ 'package' ] + ); + + return if $self->{_noempty} && ! $iterator->has_results(); + + my $content = $format->get_report( + $self->{_time}, + "$type global report", + $iterator, + $type, + $columns, + $links, + undef + ); + + $self->_send_mail( + $format->type(), + $self->{_to}, + "$type global report", + $content, + ); + } +} + +sub _individual_report { + my ($self, $resultset, $type, $columns, $links, $maintainer) = @_; + + foreach my $format (@{$self->{_formats}}) { + my $iterator = $resultset->get_iterator( + $type, + [ 'package' ], + { maintainer => [ $maintainer ] } + ); + + return if $self->{_noempty} && ! $iterator->has_results(); + + my $content = $format->get_report( + $self->{_time}, + "$type individual report for $maintainer", + $iterator, + $type, + $columns, + $links, + $maintainer + ); + + $self->_send_mail( + $format->type(), + $maintainer, + "$type individual report for $maintainer", + $content, + ); + } + +} + +sub _send_mail { + my ($self, $type, $to, $subject, $content) = @_; + + return unless $content; + + my $mail = MIME::Entity->build( + 'Type' => $type, + 'From' => $self->{_from}, + 'Reply-To' => $self->{_reply_to}, + 'To' => $to, + 'Subject' => $subject, + 'Data' => $$content + ); + + if ($self->{_test}) { + $mail->print(\*STDOUT); + } else { + open(MAIL, "| $self->{_mta} -t -oi -oem") or die "Can't open MTA program: $!"; + $mail->print(\*MAIL); + close MAIL; + } +} + +=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/Output/Mail/Format.pm b/lib/Youri/Check/Output/Mail/Format.pm new file mode 100644 index 0000000..dee269e --- /dev/null +++ b/lib/Youri/Check/Output/Mail/Format.pm @@ -0,0 +1,66 @@ +# $Id: Base.pm 579 2006-01-09 21:17:54Z guillomovitch $ +package Youri::Check::Output::Mail::Format; + +=head1 NAME + +Youri::Check::Output::Mail::Format - Abstract mail format support + +=head1 DESCRIPTION + +This abstract class defines the format support interface for +L<Youri::Check::Output::Mail>. + +=cut + +use warnings; +use strict; +use Carp; + +sub new { + my $class = shift; + croak "Abstract class" if $class eq __PACKAGE__; + + my %options = ( + id => '', + test => 0, + verbose => 0, + @_ + ); + + my $self = bless { + _id => $options{id}, + _test => $options{test}, + _verbose => $options{verbose}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head2 get_id() + +Returns format handler identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=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/Output/Mail/Format/HTML.pm b/lib/Youri/Check/Output/Mail/Format/HTML.pm new file mode 100644 index 0000000..8ed4b28 --- /dev/null +++ b/lib/Youri/Check/Output/Mail/Format/HTML.pm @@ -0,0 +1,158 @@ +# $Id: Mail.pm 580 2006-01-11 22:59:36Z guillomovitch $ +package Youri::Check::Output::Mail::Format::HTML; + +=head1 NAME + +Youri::Check::Output::Mail::Format::HTML - Mail HTML format support + +=head1 DESCRIPTION + +This format plugin for L<Youri::Check::Output::Mail> provides HTML format +support. + +=cut + +use warnings; +use strict; +use Carp; +use CGI; +use base 'Youri::Check::Output::Mail::Format'; + +sub type { + return 'text/html'; +} + +sub _init { + my $self = shift; + my %options = ( + style => <<EOF, # css style +h1 { + text-align:center; +} +table { + border-style:solid; + border-width:1px; + border-color:black; + width:100%; +} +tr.odd { + background-color:white; +} +tr.even { + background-color:silver; +} +p.footer { + font-size:smaller; + text-align:center; +} +EOF + @_ + ); + + $self->{_style} = $options{style}; + $self->{_cgi} = CGI->new(); +} + +sub get_report { + my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_; + + my $body; + my $lead_columns = [ + $maintainer ? + qw/package media/ : + qw/package media maintainer/ + ]; + my $line; + my @results; + $body .= $self->{_cgi}->start_table(); + $body .= $self->{_cgi}->Tr([ + $self->{_cgi}->th([ + @$lead_columns, + @$columns + ]) + ]); + while (my $result = $iterator->get_result()) { + if (@results && $result->{package} ne $results[0]->{package}) { + $body .= $self->_get_formated_results( + $lead_columns, + $columns, + $links, + $line++ % 2 ? 'odd' : 'even', + \@results + ); + @results = (); + } + push(@results, $result); + } + $body .= $self->_get_formated_results( + $lead_columns, + $columns, + $links, + $line++ % 2 ? 'odd' : 'even', + \@results + ); + $body .= $self->{_cgi}->end_table(); + + my $content; + $content .= $self->{_cgi}->start_html( + -title => $title, + -style => { code => $self->{_style} } + ); + $content .= $self->{_cgi}->h1($title); + $content .= $body; + $content .= $self->{_cgi}->hr(); + $content .= $self->{_cgi}->p( + { class => 'footer' }, + "Page generated $time" + ); + $content .= $self->{_cgi}->end_html(); + + return \$content; +} + +sub _get_formated_results { + my ($self, $lead_columns, $columns, $links, $class, $results) = @_; + + my $content; + $content .= $self->{_cgi}->end_Tr(); + for my $i (0 .. $#$results) { + $content .= $self->{_cgi}->start_Tr( + { class => $class } + ); + if ($i == 0) { + # first line contains spanned cells + $content .= $self->{_cgi}->td( + { rowspan => scalar @$results }, + [ + map { $results->[$i]->{$_} } + @$lead_columns + ] + ); + } + $content .= $self->{_cgi}->td( + [ + map { + $links->{$_} && $results->[$i]->{$links->{$_}} ? + $self->{_cgi}->a( + { href => $results->[$i]->{$links->{$_}} }, + $self->{_cgi}->escapeHTML($results->[$i]->{$_}) + ) : + $self->{_cgi}->escapeHTML($results->[$i]->{$_}) + } @$columns + ] + ); + $content .= $self->{_cgi}->end_Tr(); + } + + return $content; +} + +=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/Output/Mail/Format/Text.pm b/lib/Youri/Check/Output/Mail/Format/Text.pm new file mode 100644 index 0000000..f08e840 --- /dev/null +++ b/lib/Youri/Check/Output/Mail/Format/Text.pm @@ -0,0 +1,83 @@ +# $Id: Mail.pm 580 2006-01-11 22:59:36Z guillomovitch $ +package Youri::Check::Output::Mail::Format::Text; + +=head1 NAME + +Youri::Check::Output::Mail::Format::Text - Mail text format support + +=head1 DESCRIPTION + +This format plugin for L<Youri::Check::Output::Mail> provides text format +support. + +=cut + +use warnings; +use strict; +use Carp; +use base 'Youri::Check::Output::Mail::Format'; + +sub type { + return 'text/plain'; +} + +sub get_report { + my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_; + + my $content; + my $lead_columns = [ + $maintainer ? + qw/package media/ : + qw/package media maintainer/ + ]; + my @results; + $content .= join("\t", @$lead_columns, @$columns) . "\n"; + while (my $result = $iterator->get_result()) { + if (@results && $result->{package} ne $results[0]->{package}) { + $content .= $self->_get_formated_results( + $lead_columns, + $columns, + \@results + ); + @results = (); + } + push(@results, $result); + } + + $content .= $self->_get_formated_results( + $lead_columns, + $columns, + \@results + ); + + return \$content; +} + +sub _get_formated_results { + my ($self, $lead_columns, $columns, $results) = @_; + + my $content; + $content .= join( + "\t", + (map { $results->[0]->{$_} || '' } @$lead_columns), + (map { $results->[0]->{$_} || '' } @$columns) + ) . "\n"; + for my $i (1 .. $#$results) { + $content .= join( + "\t", + (map { '' } @$lead_columns), + (map { $results->[$i]->{$_} || '' } @$columns) + ) . "\n"; + } + return $content; +} + +=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/Resultset.pm b/lib/Youri/Check/Resultset.pm new file mode 100644 index 0000000..d956998 --- /dev/null +++ b/lib/Youri/Check/Resultset.pm @@ -0,0 +1,116 @@ +# $Id: Base.pm 483 2005-08-01 21:39:05Z guillomovitch $ +package Youri::Check::Resultset; + +=head1 NAME + +Youri::Check::Resultset - Abstract resultset + +=head1 DESCRIPTION + +This abstract class defines Youri::Check::Resultset interface + +=cut + +use warnings; +use strict; +use Carp; +use Scalar::Util qw/blessed/; +use Youri::Utils; + +=head1 CLASS METHODS + +=head2 new(%hash) + +Creates and returns a new Youri::Check::Resultset object. + +No generic parameters (subclasses may define additional ones). + +Warning: do not call directly, call subclass constructor instead. + +=cut + +sub new { + my $class = shift; + my %options = ( + test => 0, # test mode + verbose => 0, # verbose mode + resolver => undef, # maintainer resolver, + mode => 'output', # access mode + @_ + ); + + croak "Abstract class" if $class eq __PACKAGE__; + + my $self = bless { + _test => $options{test}, + _verbose => $options{verbose}, + _resolver => $options{resolver}, + _mode => $options{mode} + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head1 INSTANCE METHODS + +=head2 set_resolver() + +Set L<Youri::Check::Maintainer::Resolver> object used to resolve package +maintainers. + +=cut + +sub set_resolver { + my ($self, $resolver) = @_; + croak "Not a class method" unless ref $self; + + croak "resolver should be a Youri::Check::Maintainer::Resolver object" + unless blessed $resolver && + $resolver->isa("Youri::Check::Maintainer::Resolver"); + + $self->{_resolver} = $resolver; +} + +=head2 clone() + +Clone resultset object. + +=head2 reset() + +Reset resultset object, by deleting all contained results. + +=head2 add_result($type, $media, $package, $values) + +Add given hash reference as a new result for given type and L<Youri::Package> object. + +=head2 get_maintainers() + +Returns the list of all maintainers with results. + +=head2 get_iterator($id, $sort, $filter) + +Returns a L<Youri::Check::Resultset::Iterator> object over results for given input it, with optional sort and filter directives. + +sort must be an arrayref of column names, such as [ 'package' ]. + +filter must be a hashref of arrayref of acceptables values indexed by column names, such as { level => [ 'warning', 'error'] }. + +=head1 SUBCLASSING + +All instances methods have to be implemented. + +=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/Resultset/DBI.pm b/lib/Youri/Check/Resultset/DBI.pm new file mode 100644 index 0000000..8537af4 --- /dev/null +++ b/lib/Youri/Check/Resultset/DBI.pm @@ -0,0 +1,372 @@ +# $Id: Result.pm 485 2005-08-01 21:48:21Z guillomovitch $ +package Youri::Check::Resultset::DBI; + +=head1 NAME + +Youri::Check::Resultset::DBI - DBI-based resultset + +=head1 DESCRIPTION + +This is a DBI-based L<Youri::Check::Resultset> implementation. + +It can be created with any DBI-supported database. + +=cut + +use warnings; +use strict; +use Carp; +use DBI 1.38; +use base 'Youri::Check::Resultset'; + +my %tables = ( + packages => { + id => 'SERIAL PRIMARY KEY', + package => 'TEXT', + media => 'TEXT', + maintainer => 'TEXT', + } +); + +my %queries = ( + add_package => + 'INSERT INTO packages (package, media, maintainer) VALUES (?, ?, ?)', + get_package_id => + 'SELECT id FROM packages WHERE package = ?', + get_maintainers => + 'SELECT DISTINCT(maintainer) FROM packages WHERE maintainer IS NOT NULL', +); + +=head1 CLASS METHODS + +=head2 new(%hash) + +Creates and returns a new Youri::Check::Resultset::DBI object. + +Specific parameters: + +=over + +=item driver $driver + +Use given string as DBI driver. + +=item base $base + +Use given string as database name. + +=item port $port + +Use given string as database port. + +=item user $user + +Use given string as database user. + +=item pass $pass + +Use given string as database password. + +=back + +=cut + +sub _init { + my $self = shift; + my %options = ( + driver => '', # driver + base => '', # base + port => '', # port + user => '', # user + pass => '', # pass + @_ + ); + + croak "No driver defined" unless $options{driver}; + croak "No base defined" unless $options{base}; + + my $datasource = "DBI:$options{driver}:dbname=$options{base}"; + $datasource .= ";host=$options{host}" if $options{host}; + $datasource .= ";port=$options{port}" if $options{port}; + + $self->{_dbh} = DBI->connect($datasource, $options{user}, $options{pass}, { + RaiseError => 1, + PrintError => 0, + AutoCommit => 1 + }) or croak "Unable to connect: $DBI::errstr"; + + $self->{_dbh}->trace($options{verbose} - 1) if $options{verbose} > 1; +} + +sub clone { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + my $clone = bless { + _test => $self->{_test}, + _verbose => $self->{_verbose}, + _resolver => $self->{_resolver}, + _dbh => $self->{_dbh}->clone() + }, ref $self; + + return $clone; +} + +sub reset { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + foreach my $table ($self->_get_tables()) { + my $query = "DROP TABLE $table"; + $self->{_dbh}->do($query); + } + + foreach my $table (keys %tables) { + $self->_create_table($table, $tables{$table}); + } +} + +sub _get_tables { + my ($self) = @_; + my @tables = $self->{_dbh}->tables(undef, undef, '%', 'TABLE'); + # unquote table name if needed + my $char = $self->{_dbh}->get_info(29); + @tables = map { substr($_, 1 , -1) } @tables if $char; + return @tables; +} + +sub _get_columns { + my ($self, $table) = @_; + # proper way would be to use column_info(), but unfortunatly DBD::SQLite + # doesn't support it :( + return + keys + %{$self->{_dbh}->selectrow_hashref("SELECT * from $table")}; +} + +sub _create_table { + my ($self, $name, $fields) = @_; + + my $query = "CREATE TABLE $name (" . + join(',', + map { "$_ $fields->{$_}" } + keys %$fields + ) . + ")"; + $self->{_dbh}->do($query); +} + +sub add_result { + my ($self, $type, $media, $package, $values) = @_; + croak "Not a class method" unless ref $self; + croak "No type defined" unless $type; + croak "No package defined" unless $package; + croak "No values defined" unless $values; + + my $key = "add_$type"; + my $sth = $self->{_sths}->{$key}; + + unless ($sth) { + my @fields = keys %$values; + $self->_create_table($type, { + 'package_id' => 'INT', + map { $_ => 'TEXT' } @fields + }); + my $query = "INSERT INTO $type (" . + join(',', 'package_id', @fields) . + ") VALUES (" . + join(',', '?', map { '?' } @fields) . + ")"; + $sth = $self->{_dbh}->prepare($query); + $self->{_sths}->{$key} = $sth; + } + + print "adding result for type $type and package $package\n" + if $self->{_verbose} > 0; + + $sth->execute( + $self->_get_package_id( + $package->get_canonical_name(), + $media->get_name(), + ), + values %$values + ); +} + +sub get_types { + my ($self) = @_; + + return + grep { ! $tables{$_} } + $self->_get_tables(); +} + +sub get_maintainers { + my ($self) = @_; + + return $self->_get_multiple_values('get_maintainers'); +} + +sub get_iterator { + my ($self, $id, $sort, $filter) = @_; + + die 'No id given, aborting' + unless $id; + die 'sort should be an arrayref' + if $sort and ref $sort ne 'ARRAY'; + die 'filter should be an hashref' + if $filter and ref $filter ne 'HASH'; + + my $query = $self->_get_iterator_query($id, $sort, $filter); + + my $sth = $self->{_dbh}->prepare($query); + $sth->execute(); + + return Youri::Check::Resultset::DBI::Iterator->new($sth); +} + +sub _get_iterator_query { + my ($self, $table, $sort, $filter) = @_; + + my @fields = + grep { ! /package_id/ } + $self->_get_columns($table); + + my $query = "SELECT DISTINCT " . + join(',', qw/package media maintainer/, @fields) . + " FROM $table, packages" . + " WHERE packages.id = $table.package_id"; + + if ($filter) { + foreach my $column (keys %{$filter}) { + foreach my $value (@{$filter->{$column}}) { + $query .= " AND $column = " . $self->{_dbh}->quote($value); + } + } + } + + if ($sort) { + $query .= " ORDER BY " . join(', ', @{$sort}); + } + + return $query; +} + +sub _get_package_id { + my ($self, $package, $media) = @_; + + my $id = $self->_get_single_value( + 'get_package_id', + $package + ); + $id = $self->_add_package($package, $media) unless $id; + + return $id; +} + +sub _add_package { + my ($self, $package, $media) = @_; + + my $maintainer = $self->{_resolver} ? + $self->{_resolver}->get_maintainer($package) : + undef; + + my $sth = + $self->{_sths}->{add_package} ||= + $self->{_dbh}->prepare($queries{add_package}); + + $sth->execute( + $package, + $media, + $maintainer + ); + + my $id = $self->{_dbh}->last_insert_id(undef, undef, 'packages', 'id'); + + return $id; +} + +sub _get_single_value { + my ($self, $query, @values) = @_; + + my $sth = + $self->{_sths}->{$query} ||= + $self->{_dbh}->prepare($queries{$query}); + + $sth->execute(@values); + + my @row = $sth->fetchrow_array(); + return @row ? $row[0]: undef; +} + +sub _get_multiple_values { + my ($self, $query, @values) = @_; + + my $sth = + $self->{_sths}->{$query} ||= + $self->{_dbh}->prepare($queries{$query}); + + $sth->execute(@values); + + my @results; + while (my @row = $sth->fetchrow_array()) { + push @results, $row[0]; + } + return @results; +} + +# close database connection +sub DESTROY { + my ($self) = @_; + + foreach my $sth (values %{$self->{_sths}}) { + $sth->finish() if $sth; + } + + # warning, may be called before _dbh is created + $self->{_dbh}->disconnect() if $self->{_dbh}; +} + +package Youri::Check::Resultset::DBI::Iterator; + +sub new { + my ($class, $sth) = @_; + + my $self = bless { + _sth => $sth, + _queue => [] + }, $class; + + return $self; +} + +sub has_results { + my ($self) = @_; + + return 1 if @{$self->{_queue}}; + + push( + @{$self->{_queue}}, + $self->{_sth}->fetchrow_hashref() + ); + + return defined $self->{_queue}->[-1]; +} + +sub get_result { + my ($self) = @_; + + return @{$self->{_queue}} ? + shift @{$self->{_queue}}: + $self->{_sth}->fetchrow_hashref(); +} + +=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/Resultset/Iterator.pm b/lib/Youri/Check/Resultset/Iterator.pm new file mode 100644 index 0000000..56e7e9a --- /dev/null +++ b/lib/Youri/Check/Resultset/Iterator.pm @@ -0,0 +1,22 @@ +# $Id: Base.pm 483 2005-08-01 21:39:05Z guillomovitch $ +package Youri::Check::Resultset::Iterator; + +=head1 INSTANCE METHODS + +=head2 has_results() + +Returns true if results are available. + +=head2 get_result() + +Returns next available result, as an field => value hash reference. + +=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; |