diff options
author | Nicolas Vigier <boklm@mageia.org> | 2011-01-06 01:07:55 +0000 |
---|---|---|
committer | Nicolas Vigier <boklm@mageia.org> | 2011-01-06 01:07:55 +0000 |
commit | a4f149873af1e9cff9ab0829adfcd3eca1a3780d (patch) | |
tree | c1345b951f4c67e3e9c5bf57f984c3e9f901f17f /lib | |
download | mga-youri-core-a4f149873af1e9cff9ab0829adfcd3eca1a3780d.tar mga-youri-core-a4f149873af1e9cff9ab0829adfcd3eca1a3780d.tar.gz mga-youri-core-a4f149873af1e9cff9ab0829adfcd3eca1a3780d.tar.bz2 mga-youri-core-a4f149873af1e9cff9ab0829adfcd3eca1a3780d.tar.xz mga-youri-core-a4f149873af1e9cff9ab0829adfcd3eca1a3780d.zip |
search in core, nonfree, tainted instead of main, contrib
Diffstat (limited to 'lib')
56 files changed, 9406 insertions, 0 deletions
diff --git a/lib/Youri/Bugzilla.pm b/lib/Youri/Bugzilla.pm new file mode 100644 index 0000000..098de0e --- /dev/null +++ b/lib/Youri/Bugzilla.pm @@ -0,0 +1,482 @@ +# $Id: Bugzilla.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Bugzilla; + +=head1 NAME + +Youri::Bugzilla - Youri Bugzilla interface + +=head1 SYNOPSIS + + use Youri::Bugzilla; + + my $bugzilla = Youri::Bugzilla->new($host, $base, $user, $pass); + + print $bugzilla->get_maintainer('foobar'); + +=head1 DESCRIPTION + +This module implement a database-level Bugzilla interface for managing packages. + +The legacy Bugzilla database model is mapped this way: + +=over + +=item * + +a maintainer is a user + +=item * + +a package is a product + +=item * + +each package has two pseudo components "program" and "package", owned by the package maintainer + +=back + +=cut + +use DBI; +use Carp; +use strict; +use warnings; + +my %queries = ( + get_package_id => 'SELECT id FROM products WHERE name = ?', + get_maintainer_id => 'SELECT userid FROM profiles WHERE login_name = ?', + get_versions => 'SELECT value FROM versions WHERE product_id = ?', + get_components => 'SELECT name FROM components WHERE product_id = ?', + add_package => 'INSERT INTO products (name, description) VALUES (?, ?)', + add_maintainer => 'INSERT INTO profiles (login_name, cryptpassword, realname, emailflags, refreshed_when) VALUES (?, ENCRYPT(?), ?, ?, SYSDATE())', + add_component => 'INSERT INTO components (product_id, name, description,initialowner, initialqacontact) VALUES (?, ?, ?, ?, ?)', + add_version => 'INSERT INTO versions (product_id, value) VALUES (?, ?)', + del_package => 'DELETE FROM products WHERE product = ?', + del_maintainer => 'DELETE FROM profiles WHERE login_name = ?', + del_components => 'DELETE FROM components WHERE program = ?', + del_versions => 'DELETE FROM versions WHERE program = ?', + reset_password => 'UPDATE profiles SET cryptpassword = ENCRYPT(?) WHERE login_name = ?', + browse_packages => <<EOF, +SELECT products.name, max(versions.value), login_name +FROM products, versions, profiles, components +WHERE versions.product_id = products.id + AND components.product_id = products.id + AND profiles.userid = components.initialowner + AND components.name = 'package' +GROUP BY name +EOF + get_maintainer => <<EOF +SELECT login_name +FROM profiles, components, products +WHERE profiles.userid = components.initialowner + AND components.name = 'package' + AND components.product_id = products.id + AND products.name = ? +EOF +); + +my @default_flags = qw/ + ExcludeSelf + FlagRequestee + FlagRequester + emailOwnerRemoveme + emailOwnerComments + emailOwnerAttachments + emailOwnerStatus + emailOwnerResolved + emailOwnerKeywords + emailOwnerCC + emailOwnerOther + emailOwnerUnconfirmed + emailReporterRemoveme + emailReporterComments + emailReporterAttachments + emailReporterStatus + emailReporterResolved + emailReporterKeywords + emailReporterCC + emailReporterOther + emailReporterUnconfirmed + emailQAcontactRemoveme + emailQAcontactComments + emailQAcontactAttachments + emailQAcontactStatus + emailQAcontactResolved + emailQAcontactKeywords + emailQAcontactCC + emailQAcontactOther + emailQAcontactUnconfirmed + emailCClistRemoveme + emailCClistComments + emailCClistAttachments + emailCClistStatus + emailCClistResolved + emailCClistKeywords + emailCClistCC + emailCClistOther + emailCClistUnconfirmed + emailVoterRemoveme + emailVoterComments + emailVoterAttachments + emailVoterStatus + emailVoterResolved + emailVoterKeywords + emailVoterCC + emailVoterOther + emailVoterUnconfirmed +/; + +my $default_flags = join('~', map { "$_~on" } @default_flags); + +=head1 CLASS METHODS + +Except stated otherwise, maintainers are specified by their login, and packages +are specified by their name. + +=head2 new($host, $base, $user, $password) + +Creates a new L<Youri::Bugzilla> object, wrapping bugzilla database I<$base> +hosted on I<$host>, and accessed by user I<$user> with password I<$password>. + +=cut + +sub new { + my ($class, $host, $base, $user, $pass) = @_; + + my $dbh = DBI->connect("DBI:mysql:database=$base;host=$host", $user, $pass) or croak "Unable to connect: $DBI::errstr"; + + my $self = bless { + _dbh => $dbh + }, $class; + + return $self; +} + +=head1 INSTANCE METHODS + +=head2 has_package($package) + +Return true if bugzilla contains given package. + +=cut + +sub has_package { + my ($self, $package) = @_; + return $self->_get_package_id($package); +} + +=head2 has_maintainer($maintainer) + +Return true if bugzilla contains given maintainer. + +=cut + +sub has_maintainer { + my ($self, $maintainer) = @_; + return $self->_get_maintainer_id($maintainer); +} + +=head2 get_maintainer($package) + +Return maintainer of given package. + +=cut + +sub get_maintainer { + my ($self, $package) = @_; + return $self->_get_single('get_maintainer', $package); +} + +=head2 get_versions($package) + +Return versions from given package. + +=cut + +sub get_versions { + my ($self, $package) = @_; + return $self->_get_multiple( + 'get_versions', + $self->_get_package_id($package) + ); +} + +=head2 get_components($package) + +Return components from given package. + +=cut + +sub get_components { + my ($self, $package) = @_; + return $self->_get_multiple( + 'get_components', + $self->_get_package_id($package) + ); +} + +=head2 get_packages() + +Return all packages from the database. + +=cut + +sub get_packages { + my ($self) = @_; + return $self->_get_multiple('get_packages'); +} + +sub _get_package_id { + my ($self, $package) = @_; + return $self->_get_single('get_package_id', $package); +} + +sub _get_maintainer_id { + my ($self, $maintainer) = @_; + return $self->_get_single('get_maintainer_id', $maintainer); +} + +sub _get_single { + my ($self, $type, $value) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{$type}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{$type}); + $self->{_queries}->{$type} = $query; + } + + $query->execute($value); + + my @row = $query->fetchrow_array(); + return @row ? $row[0]: undef; +} + +sub _get_multiple { + my ($self, $type, $value) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{$type}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{$type}); + $self->{_queries}->{$type} = $query; + } + + $query->execute($value); + + my @results; + while (my @row = $query->fetchrow_array()) { + push @results, $row[0]; + } + return @results; +} + +=head2 add_package($name, $summary, $version, $maintainer, $contact) + +Adds a new package in the database, with given name, summary, version, +maintainer and initial QA contact. + +=cut + +sub add_package { + my ($self, $name, $summary, $version, $maintainer, $contact) = @_; + return unless ref $self; + + my $maintainer_id = $self->_get_maintainer_id($maintainer); + unless ($maintainer_id) { + carp "Unknown maintainer $maintainer, aborting"; + return; + } + + my $contact_id = $self->_get_maintainer_id($contact); + unless ($contact_id) { + carp "Unknown QA contact $contact, aborting"; + return; + } + + my $query = $self->{_queries}->{add_package}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_package}); + $self->{_queries}->{add_package} = $query; + } + + $query->execute($name, $summary); + + my $package_id = $self->_get_package_id($name); + + $self->_add_version($package_id, $version); + $self->_add_component( + $package_id, + 'package', + 'problem related to the package', + $maintainer_id, + $contact_id + ); + $self->_add_component( + $package_id, + 'program', + 'problem related to the program', + $maintainer_id, + $contact_id + ); +} + +=head2 add_version($package, $version) + +Adds a new version to given package. + +=cut + +sub add_version { + my ($self, $package, $version) = @_; + return unless ref $self; + + my $package_id = $self->_get_package_id($package); + $self->_add_version($package_id, $version); +} + +sub _add_version { + my ($self, $package_id, $version) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{add_version}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_version}); + $self->{_queries}->{add_version} = $query; + } + + $query->execute($package_id, $version); +} + + +=head2 add_maintainer($name, $login, $password) + +Adds a new maintainer in the database, with given name, login and password. + +=cut + +sub add_maintainer { + my ($self, $name, $login, $pass) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{add_maintainer}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_maintainer}); + $self->{_queries}->{add_maintainer} = $query; + } + + $query->execute($login, $pass, $name, $default_flags); +} + +sub _add_component { + my ($self, $package_id, $name, $description, $maintainer_id, $contact_id) = @_; + + my $query = $self->{_queries}->{add_component}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{add_component}); + $self->{_queries}->{add_component} = $query; + } + + $query->execute($package_id, $name, $description, $maintainer_id, $contact_id); +} + +=head2 del_package($package) + +Delete given package from database. + +=cut + +sub del_package { + my ($self, $package) = @_; + $self->_delete('del_package', $package); + $self->_delete('del_versions', $package); + $self->_delete('del_components', $package); +} + +=head2 del_maintainer($maintainer) + +Delete given maintainer from database. + +=cut + +sub del_maintainer { + my ($self, $maintainer) = @_; + $self->_delete('del_maintainer', $maintainer); +} + +sub _delete { + my ($self, $type, $value) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{$type}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{$type}); + $self->{_queries}->{$type} = $query; + } + + $query->execute($value); +} + +=head2 reset_password(I<$maintainer>, I<$password>) + +Reset password of a maintainer to given password. + +=cut + +sub reset_password { + my ($self, $login, $pass) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{reset_password}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{reset_password}); + $self->{_queries}->{reset_password} = $query; + } + + $query->execute($pass, $login); +} + +=head2 browse_packages($callback) + +Browse all packages from bugzilla, and execute given callback with name and +maintainer as argument for each of them. + +=cut + +sub browse_packages { + my ($self, $callback) = @_; + return unless ref $self; + + my $query = $self->{_queries}->{browse_packages}; + unless ($query) { + $query = $self->{_dbh}->prepare($queries{browse_packages}); + $self->{_queries}->{browse_packages} = $query; + } + + $query->execute(); + + while (my @row = $query->fetchrow_array()) { + $callback->(@row); + } +} + +# close database connection +sub DESTROY { + my ($self) = @_; + + foreach my $query (values %{$self->{_queries}}) { + $query->finish(); + } + + $self->{_dbh}->disconnect(); +} + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2002-2006, YOURI project + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/Youri/Check/Input.pm b/lib/Youri/Check/Input.pm new file mode 100644 index 0000000..d6a4bad --- /dev/null +++ b/lib/Youri/Check/Input.pm @@ -0,0 +1,120 @@ +# $Id: Input.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Check::Input; + +=head1 NAME + +Youri::Check::Input - Abstract input plugin + +=head1 DESCRIPTION + +This abstract class defines input plugin interface. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Utils; + +use constant WARNING => 'warning'; +use constant ERROR => 'error'; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Check::Input object. + +No generic parameters (subclasses may define additional ones). + +Warning: do not call directly, call subclass constructor instead. + +=cut + +sub new { + my $class = shift; + croak "Abstract class" if $class eq __PACKAGE__; + + my %options = ( + id => '', # object id + test => 0, # test mode + verbose => 0, # verbose mode + resolver => undef, # maintainer resolver + preferences => undef, # maintainer preferences + @_ + ); + + if ($options{resolver}) { + croak "resolver should be a Youri::Check::Maintainer::Resolver object" unless $options{resolver}->isa("Youri::Check::Maintainer::Resolver"); + } + if ($options{preferences}) { + croak "preferences should be a Youri::Check::Maintainer::Preferences object" unless $options{preferences}->isa("Youri::Check::Maintainer::Preferences"); + } + + my $self = bless { + _id => $options{id}, + _test => $options{test}, + _verbose => $options{verbose}, + _resolver => $options{resolver}, + _preferences => $options{preferences}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head1 INSTANCE METHODS + +=head2 get_id() + +Returns plugin identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=head2 prepare(@medias) + +Perform optional preliminary initialisation, using given list of +<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; diff --git a/lib/Youri/Config.pm b/lib/Youri/Config.pm new file mode 100644 index 0000000..3affa7a --- /dev/null +++ b/lib/Youri/Config.pm @@ -0,0 +1,202 @@ +# $Id: Config.pm 1709 2006-10-16 16:33:43Z warly $ +package Youri::Config; + +=head1 NAME + +Youri::Application - Youri application handler + +=head1 SYNOPSIS + + use Youri::Application; + + my $app = Youri::Application->new( + options => { + help => '|h!' + }, + directories => [ '/etc/youri', "$ENV{HOME}/.youri" ], + file => 'app.conf', + ); + + # get command line argument + my $foo = $app->get_arg('foo'); + + # get configuration file parameter + my $bar = $app->get_param('bar'); + +=head1 DESCRIPTION + +This class handle configuration for all YOURI applications. + +The command line specification is used to manage arguments through +Getopt::Long. Unless B<--config> argument is given, the list of directories is +then scanned for a file with given name, and halt as soon as it find one. If no +readable file is found, an exception is thrown. The file is then processed +through YAML::AppConfig. If parsing fails, an exception is thrown. + +=head1 CONFIGURATION FILE FORMAT + +=head2 SHARED KEYS + +In addition to the application-specific optional or mandatory parameters, all +YOURI applications support the following optional top-level parameters: + +=over + +=item B<includes> + +A list of additional configuration files. + +=item B<foo> + +An arbitrary variable, usable everywhere else in the file. + +=back + +=head2 PLUGIN DEFINITION + +All YOURI application heavily rely on plugins defined in their configuration +files. A plugin definition is composed from the following parameters: + +=over + +=item B<class> + +The class of this plugin. + +=item B<options> + +The options of this plugin. + +=back + +=head1 SEE ALSO + +YAML::AppConfig, Getopt::Long + +=cut + +use strict; +use warnings; +use YAML::AppConfig; +use Getopt::Long; +use File::Spec; +use Pod::Usage; +use Carp; + +sub new { + my ($class, %options) = @_; + + + # command line arguments + my $args = { + verbose => 0 + }; + my @args; + if ($options{args}) { + while (my ($arg, $spec) = each %{$options{args}}) { + push(@args, ($arg . $spec) => \$args->{$arg}); + } + } + push(@args, + 'config=s' => \$args->{config}, + 'h|help' => \$args->{help}, + 'v|verbose+' => \$args->{verbose} + ); + GetOptions(@args); + + if ($args->{help}) { + if (!@ARGV) { + # standard help, available immediatly + my $filename = (caller)[1]; + pod2usage( + -input => $filename, + -verbose => 0 + ); + } + } + + # config files parameters + + # find configuration file to use + my $main_file; + if ($args->{config}) { + if (! -f $args->{config}) { + croak "Non-existing file $args->{config}"; + } elsif (! -r $args->{config}) { + croak "Non-readable file $args->{config}"; + } else { + $main_file = $args->{config}; + } + } else { + foreach my $directory (@{$options{directories}}) { + my $file = "$directory/$options{file}"; + next unless -f $file && -r $file; + $main_file = $file; + last; + } + croak 'No config file found, aborting' unless $main_file; + } + + my $params; + eval { + $params = YAML::AppConfig->new(file => $main_file); + }; + if ($@) { + croak "Invalid configuration file $main_file, aborting"; + } + + # process inclusions + my $includes = $params->get('includes'); + if ($includes) { + foreach my $include_file (@{$includes}) { + # convert relative path to absolute ones + $include_file = File::Spec->rel2abs( + $include_file, (File::Spec->splitpath($main_file))[1] + ); + + if (! -f $include_file) { + warn "Non-existing file $include_file, skipping"; + } elsif (! -r $include_file) { + warn "Non-readable file $include_file, skipping"; + } else { + eval { + $params->merge(file => $include_file); + }; + if ($@) { + carp "Invalid included configuration file $include_file, skipping"; + } + } + } + } + + my $self = bless { + _args => $args, + _params => $params + }, $class; + + return $self; +} + +sub get_arg { + my ($self, $arg) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_args}->{$arg}; +} + +sub get_param { + my ($self, $param) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_params}->get($param); +} + +=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/Media.pm b/lib/Youri/Media.pm new file mode 100644 index 0000000..a9d9521 --- /dev/null +++ b/lib/Youri/Media.pm @@ -0,0 +1,311 @@ +# $Id: Media.pm 1710 2006-10-16 16:35:11Z warly $ +package Youri::Media; + +=head1 NAME + +Youri::Media - Abstract media class + +=head1 DESCRIPTION + +This abstract class defines Youri::Media interface. + +=cut + +use Carp; +use strict; +use warnings; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Media object. + +Generic parameters: + +=over + +=item id $id + +Media id. + +=item name $name + +Media name. + +=item type $type (source/binary) + +Media type. + +=item test true/false + +Test mode (default: false). + +=item verbose true/false + +Verbose mode (default: false). + +=item allow_deps $media_ids + +list of ids of medias allowed to provide dependencies. + +=item skip_tests $test_ids + +list of ids of test plugins to skip. + +=item skip_archs $arches + +list of arches to skip. + +=back + +Subclass may define additional parameters. + +Warning: do not call directly, call subclass constructor instead. + +=cut + +sub new { + my $class = shift; + croak "Abstract class" if $class eq __PACKAGE__; + + my %options = ( + name => '', # media name + canonical_name => '', # media canonical name + type => '', # media type + test => 0, # test mode + verbose => 0, # verbose mode + allow_deps => undef, # list of media ids from which deps are allowed + allow_srcs => undef, # list of media ids from which packages can be built + skip_tests => undef, # list of tests ids to skip + skip_archs => undef, # list of archs for which to skip tests + @_ + ); + + + croak "No type given" unless $options{type}; + croak "Wrong value for type: $options{type}" + unless $options{type} =~ /^(?:binary|source)$/o; + + # some options need to be arrays. Check it and convert to hashes + foreach my $option (qw(allow_deps allow_srcs skip_archs skip_tests)) { + next unless defined $options{$option}; + croak "$option should be an arrayref" unless ref $options{$option} eq 'ARRAY'; + $options{$option} = { + map { $_ => 1 } @{$options{$option}} + }; + } + + my $self = bless { + _id => $options{id}, + _name => $options{name} || $options{id}, + _type => $options{type}, + _allow_deps => $options{allow_deps}, + _allow_srcs => $options{allow_srcs}, + _skip_archs => $options{skip_archs}, + _skip_tests => $options{skip_tests}, + }, $class; + + $self->_init(%options); + + # remove unwanted archs + if ($options{skip_archs}->{all}) { + $self->_remove_all_archs() + } elsif ($options{skip_archs}) { + $self->_remove_archs($options{skip_archs}); + } + + return $self; +} + +sub _init { + # do nothing +} + +=head1 INSTANCE METHODS + +=head2 get_id() + +Returns media identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=head2 get_name() + +Returns the name of this media. + +=cut + +sub get_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_name}; +} + +=head2 get_type() + +Returns the type of this media. + +=cut + +sub get_type { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_type}; +} + +=head2 allow_deps() + +Returns the list of id of medias allowed to provide dependencies for this +media. + +=cut + +sub allow_deps { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return keys %{$self->{_allow_deps}}; +} + +=head2 allow_dep($media_id) + +Tells wether media with given id is allowed to provide dependencies for +this media. + +=cut + +sub allow_dep { + my ($self, $dep) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_allow_deps}->{all} || + $self->{_allow_deps}->{$dep}; +} + +=head2 allow_srcs() + +Returns the list medias where the source packages can be + +=cut + +sub allow_srcs { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return keys %{$self->{_allow_srcs}}; +} + +=head2 allow_src($media_id) + +Tells wether media with given id is allowed to host sources dependencies for +this media. + +=cut + +sub allow_src { + my ($self, $src) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_allow_srcs}->{all} || $self->{_allow_srcs}->{$src}; +} + +=head2 skip_archs() + +Returns the list of arch which are to be skipped for this media. + +=cut + +sub skip_archs { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return keys %{$self->{_skip_archs}}; +} + +=head2 skip_arch($arch) + +Tells wether given arch is to be skipped for this media. + +=cut + +sub skip_arch { + my ($self, $arch) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_skip_archs}->{all} || + $self->{_skip_archs}->{$arch}; +} + +=head2 skip_tests() + +Returns the list of id of test which are to be skipped for this media. + +=cut + +sub skip_tests { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return keys %{$self->{_skip_tests}}; +} + +=head2 skip_test($test_id) + +Tells wether test with given id is to be skipped for this media. + +=cut + +sub skip_test { + my ($self, $test) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_skip_tests}->{all} || + $self->{_skip_tests}->{$test}; +} + +=head2 get_package_class() + +Return package class for this media. + +=head2 traverse_files($function) + +Apply given function to all files of this media. + +=head2 traverse_headers($function) + +Apply given function to all headers of this media. + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item traverse_headers + +=item traverse_files + +=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/Media/URPM.pm b/lib/Youri/Media/URPM.pm new file mode 100644 index 0000000..b7253d9 --- /dev/null +++ b/lib/Youri/Media/URPM.pm @@ -0,0 +1,273 @@ +# $Id: URPM.pm 1179 2006-08-05 08:30:57Z warly $ +package Youri::Media::URPM; + +=head1 NAME + +Youri::Media::URPM - URPM-based media implementation + +=head1 DESCRIPTION + +This is an URPM-based L<Youri::Media> implementation. + +It can be created either from local or remote full (hdlist) or partial +(synthesis) compressed header files, or from a package directory. File-based +inputs are only usable with this latest option. + +=cut + +use URPM; +use File::Find; +use File::Temp (); +use Youri::Utils; +use LWP::Simple; +use Carp; +use strict; +use warnings; +use Youri::Package::URPM; + +use base 'Youri::Media'; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Media::URPM object. + +Specific parameters: + +=over + +=item synthesis $synthesis + +Path, URL or list of path or URL of synthesis file used for creating +this media. If a list is given, the first successfully accessed will be used, +so as to allow better reliability. + +=item hdlist $hdlist + +Path, URL or list of path or URL of hdlist file used for creating +this media. If a list is given, the first successfully accessed will be used, +so as to allow better reliability. + +=item path $path + +Path or list of pathes of package directory used for creating this +media. If a list is given, the first successfully accessed will be used, so as +to allow better reliability. + +=item max_age $age + +Maximum age of packages for this media. + +=item rpmlint_config $file + +rpmlint configuration file for this media. + +=back + +In case of multiple B<synthesis>, B<hdlist> and B<path> options given, they +will be tried in this order, so as to minimize parsing time. + +=cut + +sub _init { + my $self = shift; + + my %options = ( + hdlist => '', # hdlist from which to create this media + synthesis => '', # synthesis from which to create this media + path => '', # directory from which to create this media + max_age => '', # maximum build age for packages + rpmlint_config => '', # rpmlint configuration for packages + @_ + ); + + my $urpm = URPM->new(); + SOURCE: { + if ($options{synthesis}) { + foreach my $file ( + ref $options{synthesis} eq 'ARRAY' ? + @{$options{synthesis}} : + $options{synthesis} + ) { + print "Attempting to retrieve synthesis $file\n" + if $options{verbose}; + my $synthesis = $self->_get_file($file); + if ($synthesis) { + $urpm->parse_synthesis($synthesis, keep_all_tags => 1); + last SOURCE; + } + } + } + + if ($options{hdlist}) { + foreach my $file ( + ref $options{hdlist} eq 'ARRAY' ? + @{$options{hdlist}} : + $options{hdlist} + ) { + print "Attempting to retrieve hdlist $file\n" + if $options{verbose}; + my $hdlist = $self->_get_file($file); + if ($hdlist) { + $urpm->parse_hdlist($hdlist, keep_all_tags => 1); + last SOURCE; + } + } + } + + if ($options{path}) { + foreach my $path ( + ref $options{path} eq 'ARRAY' ? + @{$options{path}} : + $options{path} + ) { + print "Attempting to scan directory $path\n" + if $options{verbose}; + unless (-d $path) { + carp "non-existing directory $path"; + next; + } + unless (-r $path) { + carp "non-readable directory $path"; + next; + } + + my $parse = sub { + return unless -f $File::Find::name; + return unless -r $File::Find::name; + return unless /\.rpm$/; + + $urpm->parse_rpm($File::Find::name, keep_all_tags => 1); + }; + + find($parse, $path); + last SOURCE; + } + } + + croak "no source specified"; + } + + $self->{_urpm} = $urpm; + $self->{_path} = $options{path}; + $self->{_max_age} = $options{max_age}; + $self->{_rpmlint_config} = $options{rpmlint_config}; + + return $self; +} + +sub _remove_all_archs { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + $self->{_urpm}->{depslist} = []; +} + +sub _remove_archs { + my ($self, $skip_archs) = @_; + croak "Not a class method" unless ref $self; + + my $urpm = $self->{_urpm}; + $urpm->{depslist} = [ + grep { ! $skip_archs->{$_->arch()} } @{$urpm->{depslist}} + ]; +} + +=head1 INSTANCE METHODS + +=head2 max_age() + +Returns maximum age of packages for this media. + +=cut + +sub max_age { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_max_age}; +} + +=head2 rpmlint_config() + +Returns rpmlint configuration file for this media. + +=cut + +sub rpmlint_config { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_rpmlint_config}; +} + +sub get_package_class { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return "Youri::Package::URPM"; +} + +sub traverse_files { + my ($self, $function) = @_; + croak "Not a class method" unless ref $self; + + my $callback = sub { + return unless -f $File::Find::name; + return unless -r $File::Find::name; + return unless $_ =~ /\.rpm$/; + + my $package = Youri::Package::URPM->new(file => $File::Find::name); + return if $self->{_skip_archs}->{$package->get_arch()}; + + $function->($File::Find::name, $package); + }; + + find($callback, $self->{_path}); +} + +sub traverse_headers { + my ($self, $function) = @_; + croak "Not a class method" unless ref $self; + + $self->{_urpm}->traverse(sub { + local $_; # workaround mysterious problem between URPM and AppConfig + $function->(Youri::Package::URPM->new(header => $_[0])); + }); + +} + +sub _get_file { + my ($self, $file) = @_; + + if ($file =~ /^(?:http|ftp):\/\/.*$/) { + my $tempfile = File::Temp->new(); + my $status = getstore($file, $tempfile->filename()); + unless (is_success($status)) { + carp "invalid URL $file: $status"; + return; + } + return $tempfile; + } else { + unless (-f $file) { + carp "non-existing file $file"; + return; + } + unless (-r $file) { + carp "non-readable file $file"; + return; + } + return $file; + } +} + +=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/Package.pm b/lib/Youri/Package.pm new file mode 100644 index 0000000..5ba866a --- /dev/null +++ b/lib/Youri/Package.pm @@ -0,0 +1,336 @@ +# $Id: Package.pm 223952 2007-06-23 13:54:13Z pixel $ +package Youri::Package; + +=head1 NAME + +Youri::Package - Abstract package class + +=head1 DESCRIPTION + +This abstract class defines Youri::Package interface. + +=cut + +use Carp; +use strict; +use warnings; + +use constant DEPENDENCY_NAME => 0; +use constant DEPENDENCY_RANGE => 1; + +use constant FILE_NAME => 0; +use constant FILE_MODE => 1; +use constant FILE_MD5SUM => 2; + +use constant CHANGE_AUTHOR => 0; +use constant CHANGE_TIME => 1; +use constant CHANGE_TEXT => 2; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Package 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 = ( + @_ + ); + + my $self = bless { + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head2 get_pattern($name, $version, $release, $arch) + +Returns a pattern matching a file for a package, using available informations. + +=head2 compare_revisions($revision1, $revision2) + +Compares two revision tokens, and returns a numeric value: + +=over + +=item positive if first revision is higher + +=item null if both revisions are equal + +=item negative if first revision is lower + +=back + +=head2 check_ranges_compatibility($range1, $range2) + +Returns a true value if given revision ranges are compatible. + +=head1 INSTANCE METHODS + +=head2 as_file() + +Returns the file corresponding to this package. + +=head2 as_string() + +Returns a string representation of this package. + +=head2 as_formated_string(I<format>) + +Returns a string representation of this package, formated according to +I<format>. Format is a string, where each %{foo} token will get replaced by +equivalent tag value. + +=head2 get_name() + +Returns the name of this package. + +=head2 get_version() + +Returns the version of this package. + +=head2 get_release() + +Returns the release of this package. + +=head2 get_revision() + +Returns the revision of this package. + +=head2 get_arch() + +Returns the architecture of this package. + +=head2 get_file_name() + +Returns the file name of this package (name-version-release.arch.extension). + +=head2 is_source() + +Returns true if this package is a source package. + +=head2 is_binary() + +Returns true if this package is a binary package. + +=head2 is_debug() + +Returns true if this package is a debug package. + +=head2 get_type() + +Returns the type (binary/source) of this package. + +=head2 get_age() + +Returns the age of this package + +=head2 get_url() + +Returns the URL of this package + +=head2 get_summary() + +Returns the summary of this package + +=head2 get_description() + +Returns the description of this package + +=head2 get_packager() + +Returns the packager of this package. + +=head2 get_source_package() + +Returns the name of the source package of this package. + +=head2 get_tag($tag) + +Returns the value of tag $tag of this package. + +=head2 get_canonical_name() + +Returns the canonical name of this package, shared by its multiple components, +usually the one from the source package. + +=head2 get_requires() + +Returns the list of dependencies required by this package, each dependency +being represented as an array reference, with the following informations: + +=over + +=item B<name> + +Name of the dependency (index DEPENDENCY_NAME) + +=item B<range> + +Range of the dependency (index DEPENDENCY_RANGE) + +=back + +For more conveniency, fields index are available as constant in this package. + +=head2 get_provides() + +Returns the list of dependencies provided by this package, each dependency +being represented as an array reference, using the same structure as previous method. + +=head2 get_obsoletes() + +Returns the list of other packages obsoleted by this one, each one +being represented as an array reference, using the same structure as previous method. + +=head2 get_conflicts() + +Returns the list of other packages conflicting with this one. + +=head2 get_files() + +Returns the list of files contained in this package, each file being +represented as an array reference, with the following informations: + +=over + +=item B<name> + +Name of the file (index FILE_NAME). + +=item B<mode> + +Mode of the file (index FILE_MODE). + +=item B<md5sum> + +Md5sum of the file (index FILE_MD5SUM). + +=back + +For more conveniency, fields index are available as constant in this package. + +=head2 get_gpg_key() + +Returns the gpg key id of package signature. + +=head2 get_information() + +Returns formated informations about the package. + +=head2 get_changes() + +Returns the list of changes for this package, each change being +represented as an array reference, with the following informations: + +=over + +=item B<author> + +Author of the change (index CHANGE_AUTHOR). + +=item B<time> + +Time of the change (index CHANGE_TIME). + +=item B<text> + +Raw textual description of the change (index CHANGE_TEXT). + +=back + +For more conveniency, fields index are available as constant in this package. + +=head2 get_last_change() + +Returns the last change for this package, as as structure described before. + +=head2 compare($package) + +Compares ordering with other package, according to their corresponding revision +tokens, and returns a numeric value: + +=over + +=item positive if this package is newer + +=item null if both have same revision + +=item negative if this package is older + +=back + +=head2 satisfy_range($range) + +Returns a true value if this package revision satisfies given revision range. + +=head2 sign($name, $path, $passphrase) + +Signs the package with given name, keyring path and passphrase. + +=head2 extract() + +Extract package content in local directory. + +=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 + +sub get_file { + my ($self) = @_; + carp "Deprecated method, use as_file now"; + + return $self->as_file(); +} + +sub get_full_name { + my ($self) = @_; + carp "Deprecated method, use as_string now"; + + return $self->as_string(); +} + +sub compare_versions { + my ($self, $version1, $version2) = @_; + carp "Deprecated method, use compare_revisions now"; + + return $self->compare_revisions($version1, $version2); +} + +sub compare_ranges { + my ($self, $range1, $range2) = @_; + carp "Deprecated method, use are_range_compatible now"; + + return $self->check_ranges_compatibility($range1, $range2); +} + +sub get_revision_name { + my ($self) = @_; + carp "Deprecated method, use as_formated_string('%name-%version-%release') now"; + + return $self->as_formated_string('%{name}-%{version}-%{release}'); +} + + +1; diff --git a/lib/Youri/Package/RPM.pm b/lib/Youri/Package/RPM.pm new file mode 100644 index 0000000..1f72830 --- /dev/null +++ b/lib/Youri/Package/RPM.pm @@ -0,0 +1,58 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Package/URPM.pm 2257 2006-07-05T09:22:47.088572Z guillaume $ +package Youri::Package::RPM; + +=head1 NAME + +Youri::Package::RPM - Base class for all RPM-based package implementation + +=head1 DESCRIPTION + +This bases class factorize code between various RPM-based package +implementation. + +=cut + +use strict; +use warnings; +use base 'Youri::Package'; +use Carp; + +sub get_pattern { + my ($class, $name, $version, $release, $arch) = @_; + + return + ($name ? quotemeta($name) : '[\w-]+' ). + '-' . + ($version ? quotemeta($version) : '[^-]+' ). + '-' . + ($release ? quotemeta($release) : '[^-]+' ). + '\.' . + ($arch ? quotemeta($arch) : '\w+' ). + '\.rpm'; +} + +sub as_file { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_file}; +} + +sub is_debug { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + my $name = $self->get_name(); + my $group = $self->get_tag('group'); + + # debug packages' names must end in -debug, except kernel + if ($group =~ m,^Development/Debug$, && + ($name =~ /-debug$/o || $name =~ /^kernel-.*-debug/o)) { + return 1; + } + else { + return 0; + } +} + +1; diff --git a/lib/Youri/Package/RPM4.pm b/lib/Youri/Package/RPM4.pm new file mode 100644 index 0000000..b1ed5d8 --- /dev/null +++ b/lib/Youri/Package/RPM4.pm @@ -0,0 +1,424 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Package/URPM.pm 2129 2006-06-23T09:41:01.599329Z guillomovitch $ +package Youri::Package::RPM4; + +=head1 NAME + +Youri::Package::RPM4 - URPM-based rpm package implementation + +=head1 DESCRIPTION + +This is an RPM4-based L<Youri::Package> implementation for rpm. + +=cut + +use strict; +use warnings; +use Carp; +use RPM4; +use RPM4::Header; +use RPM4::Sign; +use File::Spec; +use Scalar::Util qw/refaddr/; +use base 'Youri::Package::RPM'; +use overload + '""' => 'as_string', + '0+' => '_to_number', + fallback => 1; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Package::RPM4 object. + +Specific parameters: + +=over + +=item file $file + +Path of file to use for creating this package. + +=item header $header + +L<RPM4::Header> object to use for creating this package. + +=back + +=cut + +sub _init { + my ($self, %options) = @_; + + my $header; + HEADER: { + if (exists $options{header}) { + croak "undefined header" + unless $options{header}; + croak "invalid header" + unless $options{header}->isa('RPM4::Header'); + $header = $options{header}; + last HEADER; + } + + if (exists $options{file}) { + croak "undefined file" + unless $options{file}; + croak "non-existing file $options{file}" + unless -f $options{file}; + croak "non-readable file $options{file}" + unless -r $options{file}; + $header = RPM4::Header->new($options{file}); + croak "Can't get header from file $options{file}" if (!$header); + + last HEADER; + } + + croak "no way to extract header from arguments"; + } + + $self->{_header} = $header; + $self->{_file} = File::Spec->rel2abs($options{file}); +} + +sub compare_versions { + my ($class, $version1, $version2) = @_; + + return RPM4::rpmvercmp($version1, $version2); +} + +sub _depsense2flag { + my ($string) = @_; + my @flags = 0; + push(@flags, 'EQUAL') if ($string =~ /=/); + push(@flags, 'LESS') if ($string =~ /</); + push(@flags, 'GREATER') if ($string =~ />/); + return \@flags; +} + +sub check_ranges_compatibility { + my ($class, $range1, $range2) = @_; + my @deps1 = split(/ /, $range1); + my @deps2 = split(/ /, $range2); + $deps1[1] = _depsense2flag($range1); + $deps2[1] = _depsense2flag($range2); + my $dep1 = RPM4::Header::Dependencies( + "PROVIDENAME", + \@deps1, + ); + my $dep2 = RPM4::Header::Dependencies( + "PROVIDENAME", + \@deps2, + ); + + return $dep1->overlap($dep2); +} + +sub get_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('name'); +} + +sub get_version { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('version'); +} + +sub get_release { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('release'); +} + +sub get_revision { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat('%|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}'); +} + +sub get_file_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat('%{NAME}-%{VERSION}-%{RELEASE}.%|SOURCERPM?{%{ARCH}}:{src}|.rpm'); +} + + +sub get_arch { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat('%|SOURCERPM?{%{ARCH}}:{src}|'); +} + +sub get_url { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('url'); +} + +sub get_summary { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('summary'); +} + +sub get_description { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('description'); +} + +sub get_packager { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('packager'); +} + +sub is_source { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->issrc(); +} + +sub is_binary { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return !$self->{_header}->issrc(); +} + +sub get_type { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_header}->issrc() ? + "source" : + "binary"; +} + +sub get_age { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('buildtime'); +} + +sub get_source_package { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->tag('sourcerpm'); +} + +sub get_canonical_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + $self->{_header}->sourcerpmname() =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/; + return $1; +} + +sub get_tag { + my ($self, $tag) = @_; + croak "Not a class method" unless ref $self; + #croak "invalid tag $tag" unless $self->{_header}->can($tag); + return $self->{_header}->tag($tag); +} + + +sub _get_dependencies { + my ($self, $deptype) = @_; + my $deps = $self->{_header}->dep($deptype); + my @deps_list; + if ($deps) { + $deps->init(); + while ($deps->next() >= 0) { + my @deps = $deps->info(); + $deps[1] =~ m/^rpmlib\(/ and next; # skipping internal rpmlib dep + $deps[2] =~ s/^=$/==/; # rpm say foo = 1, not foo == 1, == come from URPM, which sucks + my $range = $deps[3] ? ($deps[2] . ' ' . $deps[3]) : undef; + push(@deps_list, [ $deps[1], $range ]); + } + } + @deps_list +} + +sub get_requires { + my ($self) = @_; + + return $self->_get_dependencies('REQUIRENAME'); +} + +sub get_provides { + my ($self) = @_; + + return $self->_get_dependencies('PROVIDENAME'); +} + +sub get_obsoletes { + my ($self) = @_; + + return $self->_get_dependencies('OBSOLETENAME'); +} + +sub get_conflicts { + my ($self) = @_; + + return $self->_get_dependencies('CONFLICTNAME'); +} + +sub get_files { + my ($self) = @_; + + my $files = $self->{_header}->files(); + my @fileslist; + if ($files) { + $files->init(); + while ($files->next() >= 0) { + my $smode = $files->mode(); + my $umode = 0; + foreach (0..15) { # converting unsigned to signed int :\ + $umode |= $smode & (1 << $_); + } + push(@fileslist, [ $files->filename(), $umode, $files->md5() || '' ]); + } + } + @fileslist +} + +sub get_gpg_key { + my ($self) = @_; + + my $signature = $self->{_header}->queryformat('%{SIGGPG:pgpsig}'); + + return if $signature eq '(not a blob)'; + + my $key_id = (split(/\s+/, $signature))[-1]; + + return substr($key_id, 8); +} + +sub get_information { + my ($self) = @_; + + return $self->{_header}->queryformat(<<EOF); +Name : %-27{NAME} Relocations: %|PREFIXES?{[%{PREFIXES} ]}:{(not relocatable)}| +Version : %-27{VERSION} Vendor: %{VENDOR} +Release : %-27{RELEASE} Build Date: %{BUILDTIME:date} +Install Date: %|INSTALLTIME?{%-27{INSTALLTIME:date}}:{(not installed) }| Build Host: %{BUILDHOST} +Group : %-27{GROUP} Source RPM: %{SOURCERPM} +Size : %-27{SIZE}%|LICENSE?{ License: %{LICENSE}}| +Signature : %|DSAHEADER?{%{DSAHEADER:pgpsig}}:{%|RSAHEADER?{%{RSAHEADER:pgpsig}}:{%|SIGGPG?{%{SIGGPG:pgpsig}}:{%|SIGPGP?{%{SIGPGP:pgpsig}}:{(none)}|}|}|}| +%|PACKAGER?{Packager : %{PACKAGER}\n}|%|URL?{URL : %{URL}\n}|Summary : %{SUMMARY} +Description :\n%{DESCRIPTION} +EOF +} + +sub get_changes { + my ($self) = @_; + + my @names = $self->{_header}->tag('changelogname'); + my @time = $self->{_header}->tag('changelogtime'); + my @text = $self->{_header}->tag('changelogtext'); + + my @changes; + foreach my $i (0 .. $#names) { + $changes[$i] = [ + $names[$i], + $time[$i], + $text[$i], + ]; + } + + return @changes; +} + +sub get_last_change { + my ($self) = @_; + + return [ + ($self->{_header}->tag('changelogname'))[0], + ($self->{_header}->tag('changelogtime'))[0], + ($self->{_header}->tag('changelogtext'))[0], + ]; +} + +sub as_string { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->fullname(); +} + +sub as_formated_string { + my ($self, $format) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat($format); +} + +sub _to_number { + return refaddr($_[0]); +} + +sub compare { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->compare($package->{_header}) || 0; +} + +sub satisfy_range { + my ($self, $range) = @_; + croak "Not a class method" unless ref $self; + + return $self->check_range_compatibility($self->get_revision(), $range); +} + +sub sign { + my ($self, $name, $path, $passphrase) = @_; + croak "Not a class method" unless ref $self; + + # check if parent directory is writable + my $parent = (File::Spec->splitpath($self->{_file}))[1]; + croak "Unsignable package, parent directory is read-only" + unless -w $parent; + + my $sign = RPM4::Sign->new( + name => $name, + path => $path, + ); + $sign->{passphrase} = $passphrase; + + $sign->rpmssign($self->{_file}) +} + +sub extract { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + system("rpm2cpio $self->{_file} | cpio -id >/dev/null 2>&1"); +} + +=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/Package/Test.pm b/lib/Youri/Package/Test.pm new file mode 100644 index 0000000..edd4777 --- /dev/null +++ b/lib/Youri/Package/Test.pm @@ -0,0 +1,151 @@ +# $Id: /local/youri/soft/core/trunk/lib/Youri/Package/URPM.pm 2133 2006-09-20T21:40:20.575763Z guillaume $ +package Youri::Package::Test; + +=head1 NAME + +Youri::Package::Test - Fake test package + +=head1 DESCRIPTION + +This is just a fake package object, intended for testing purposes. + +=cut + +use strict; +use warnings; +use Carp; +use base 'Youri::Package::RPM'; +use overload + '""' => 'as_string', + '0+' => '_to_number', + fallback => 1; + +our $AUTOLOAD; + +my @tags = qw/ + name + version + release + filename + arch + url + summary + description + packager + buildtime + sourcerpm +/; + +my %tags = map { $_ => 1 } @tags; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Package::Test object. + +Specific parameters: + +=over + +=item tag $tag + +Use given value for given tag + +=back + +=cut + +sub _init { + my ($self, %options) = @_; + + $self->{"_$_"} = $options{$_} foreach keys %options; +} + +sub get_revision { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_epoch} ? + "$self->{_epoch}:$self->{_version}-$self->{_release}" : + "$self->{_version}-$self->{_release}"; +} + +sub get_tag { + my ($self, $tag) = @_; + croak "Not a class method" unless ref $self; + croak "invalid tag $tag" unless $tags{$tag}; + return $self->{'_' . $tag}; +} + +sub is_source { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_arch} eq 'src'; +} + +sub is_binary { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_arch} ne 'src'; +} + +sub get_type { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_arch} eq 'src' ? + "source" : + "binary"; +} + +sub get_canonical_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + if ($self->{_arch} eq 'src') { + return $self->{_name}; + } else { + if ($self->{_sourcerpm}) { + $self->{_sourcerpm} =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/; + return $1; + } else { + return undef; + } + } +} + +sub as_string { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_name} ? $self->{_name} : '' . + '-' . + $self->{_version} ? $self->{_version} : '' . + '-' . + $self->{_release} ? $self->{_release} : ''; +} + +sub _to_number { + return refaddr($_[0]); +} + +sub AUTOLOAD { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + my $method = $AUTOLOAD; + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + croak "invalid method" unless $method =~ /^get_(\w+)$/; + + my $tag = $1; + croak "invalid tag $tag" unless $tags{$tag}; + return $self->{'_' . $tag}; +} + +1; diff --git a/lib/Youri/Package/URPM.pm b/lib/Youri/Package/URPM.pm new file mode 100644 index 0000000..419eeb3 --- /dev/null +++ b/lib/Youri/Package/URPM.pm @@ -0,0 +1,399 @@ +# $Id: URPM.pm 266577 2010-03-02 14:51:24Z bogdano $ +package Youri::Package::URPM; + +=head1 NAME + +Youri::Package::URPM - URPM-based rpm package implementation + +=head1 DESCRIPTION + +This is an URPM-based L<Youri::Package> implementation for rpm. + +It is merely a wrapper over URPM::Package class, with a more structured +interface. + +=cut + +use strict; +use warnings; +use Carp; +use URPM; +use File::Spec; +use Expect; +use Scalar::Util qw/refaddr/; +use base 'Youri::Package::RPM'; +use overload + '""' => 'as_string', + '0+' => '_to_number', + fallback => 1; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Package::URPM object. + +Specific parameters: + +=over + +=item file $file + +Path of file to use for creating this package. + +=item header $header + +L<URPM::Package> object to use for creating this package. + +=back + +=cut + +sub _init { + my ($self, %options) = @_; + + my $header; + HEADER: { + if (exists $options{header}) { + croak "undefined header" + unless $options{header}; + croak "invalid header" + unless $options{header}->isa('URPM::Package'); + $header = $options{header}; + last HEADER; + } + + if (exists $options{file}) { + croak "undefined file" + unless $options{file}; + croak "non-existing file $options{file}" + unless -f $options{file}; + croak "non-readable file $options{file}" + unless -r $options{file}; + my $urpm = URPM->new(); + $urpm->parse_rpm($options{file}, keep_all_tags => 1); + $header = $urpm->{depslist}->[0]; + croak "non-rpm file $options{file}" unless $header; + last HEADER; + } + + croak "no way to extract header from arguments"; + } + + $self->{_header} = $header; + $self->{_file} = File::Spec->rel2abs($options{file}); +} + +sub compare_versions { + my ($class, $version1, $version2) = @_; + + return URPM::rpmvercmp($version1, $version2); +} + +sub check_ranges_compatibility { + my ($class, $range1, $range2) = @_; + + return URPM::ranges_overlap($range1, $range2); +} + +sub get_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->name(); +} + +sub get_version { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->version(); +} + +sub get_release { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->release(); +} + +sub get_revision { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat('%|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}'); +} + +sub get_file_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_file} || die "_file is not defined in header-only objects!\n"; +} + +sub get_arch { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->arch(); +} + +sub get_url { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->url(); +} + +sub get_summary { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->summary(); +} + +sub get_description { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->description(); +} + +sub get_packager { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->packager(); +} + +sub is_source { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->arch() eq 'src'; +} + +sub is_binary { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->arch() ne 'src'; +} + +sub get_type { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_header}->arch() eq 'src' ? + "source" : + "binary"; +} + +sub get_age { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->buildtime(); +} + +sub get_source_package { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->sourcerpm(); +} + +sub get_canonical_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + if ($self->{_header}->arch() eq 'src') { + return $self->{_header}->name(); + } else { + $self->{_header}->sourcerpm() =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/; + return $1; + } +} + +sub get_tag { + my ($self, $tag) = @_; + croak "Not a class method" unless ref $self; + croak "invalid tag $tag" unless $self->{_header}->can($tag); + return $self->{_header}->$tag(); +} + +sub get_requires { + my ($self) = @_; + + return map { + $_ =~ /^([^[]+)(?:\[\*\])?(?:\[(.+)\])?$/; + [ $1, $2 ] + } $self->{_header}->requires(); +} + +sub get_provides { + my ($self) = @_; + + return map { + $_ =~ /^([^[]+)(?:\[(.+)\])?$/; + [ $1, $2 && $2 ne '*' ? $2 : undef ] + } $self->{_header}->provides(); +} + +sub get_obsoletes { + my ($self) = @_; + + return map { + $_ =~ /^([^[]+)(?:\[(.+)\])?$/; + [ $1, $2 && $2 ne '*' ? $2 : undef ] + } $self->{_header}->obsoletes(); +} + +sub get_conflicts { + my ($self) = @_; + + return $self->{_header}->conflicts(); +} + +sub get_files { + my ($self) = @_; + + my @modes = $self->{_header}->files_mode(); + my @md5sums = $self->{_header}->files_md5sum(); + + return map { + [ $_, shift @modes, shift @md5sums ] + } $self->{_header}->files(); +} + +sub get_gpg_key { + my ($self) = @_; + + my $signature = $self->{_header}->queryformat('%{SIGGPG:pgpsig}'); + + return if $signature eq '(not a blob)'; + + my $key_id = (split(/\s+/, $signature))[-1]; + + return substr($key_id, 8); +} + +sub get_information { + my ($self) = @_; + + return $self->{_header}->queryformat(<<EOF); +Name : %-27{NAME} Relocations: %|PREFIXES?{[%{PREFIXES} ]}:{(not relocatable)}| +Version : %-27{VERSION} Vendor: %{VENDOR} +Release : %-27{RELEASE} Build Date: %{BUILDTIME:date} +Install Date: %|INSTALLTIME?{%-27{INSTALLTIME:date}}:{(not installed) }| Build Host: %{BUILDHOST} +Group : %-27{GROUP} Source RPM: %{SOURCERPM} +Size : %-27{SIZE}%|LICENSE?{ License: %{LICENSE}}| +Signature : %|DSAHEADER?{%{DSAHEADER:pgpsig}}:{%|RSAHEADER?{%{RSAHEADER:pgpsig}}:{%|SIGGPG?{%{SIGGPG:pgpsig}}:{%|SIGPGP?{%{SIGPGP:pgpsig}}:{(none)}|}|}|}| +%|PACKAGER?{Packager : %{PACKAGER}\n}|%|URL?{URL : %{URL}\n}|Summary : %{SUMMARY} +Description :\n%{DESCRIPTION} +EOF +} + +sub get_changes { + my ($self) = @_; + + my @names = $self->{_header}->changelog_name(); + my @time = $self->{_header}->changelog_time(); + my @text = $self->{_header}->changelog_text(); + + my @changes; + foreach my $i (0 .. $#names) { + $changes[$i] = [ + $names[$i], + $time[$i], + $text[$i], + ]; + } + + return @changes; +} + +sub get_last_change { + my ($self) = @_; + + return [ + ($self->{_header}->changelog_name())[0], + ($self->{_header}->changelog_time())[0], + ($self->{_header}->changelog_text())[0], + ]; +} + +sub as_string { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->fullname(); +} + +sub as_formated_string { + my ($self, $format) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat($format); +} + +sub _to_number { + return refaddr($_[0]); +} + +sub compare { + my ($self, $package) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->compare_pkg($package->{_header}); +} + +sub satisfy_range { + my ($self, $range) = @_; + croak "Not a class method" unless ref $self; + + return $self->check_ranges_compatibility("== " . $self->get_revision(), $range); +} + +sub sign { + my ($self, $name, $path, $passphrase, $target) = @_; + croak "Not a class method" unless ref $self; + + # check if parent directory is writable + my $parent = (File::Spec->splitpath($self->{_file}))[1]; + croak "Unsignable package, parent directory is read-only" + unless -w $parent; + + # FIXME Will have to change that + # we sign with cooker key even fro 2007.0 because this is for testing section + return !system("sudo -H /root/bin/resign_cooker $self->{_file}"); + + my $command = + 'LC_ALL=C rpm --resign ' . $self->{_file} . + ' --define "_gpg_name ' . $name . '"' . + ' --define "_gpg_path ' . $path . '"'; + my $expect = Expect->spawn($command) or die "Couldn't spawn command $command: $!\n"; + $expect->log_stdout(0); + $expect->expect(20, -re => 'Enter pass phrase:'); + $expect->send("$passphrase\n"); + + $expect->soft_close(); +} + +sub extract { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + system("rpm2cpio $self->{_file} | cpio -id >/dev/null 2>&1"); +} + +=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/Repository.pm b/lib/Youri/Repository.pm new file mode 100644 index 0000000..bbc6178 --- /dev/null +++ b/lib/Youri/Repository.pm @@ -0,0 +1,492 @@ +# $Id: Base.pm 631 2006-01-26 22:22:23Z guillomovitch $ +package Youri::Repository; + +=head1 NAME + +Youri::Repository - Abstract repository + +=head1 DESCRIPTION + +This abstract class defines Youri::Repository interface. + +=cut + +use warnings; +use strict; +use Carp; +use File::Basename; +use Youri::Package; + +=head1 CLASS METHODS + + +=head2 new(%args) + +Creates and returns a new Youri::Repository 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 = ( + install_root => '', # path to top-level directory + archive_root => '', # path to top-level directory + version_root => '', # path to top-level directory + test => 0, # test mode + verbose => 0, # verbose mode + @_ + ); + + + croak "no install root" unless $options{install_root}; + croak "invalid install root" unless -d $options{install_root}; + + my $self = bless { + _install_root => $options{install_root}, + _archive_root => $options{archive_root}, + _version_root => $options{version_root}, + _test => $options{test}, + _verbose => $options{verbose}, + }, $class; + + $self->_init(%options); + + return $self; +} + +sub _init { + # do nothing +} + +=head1 INSTANCE METHODS + +=head2 get_package_class() + +Return package class for this repository. + +=cut + +sub get_package_class { + my ($self) = @_; + croak "Not a class method" unless ref $self; + return $self->{_package_class}; +} + +=head2 get_package_charset() + +Return package charset for this repository. + +=cut + +sub get_package_charset { + my ($self) = @_; + croak "Not a class method" unless ref $self; + return $self->{_package_charset}; +} + +=head2 get_extra_arches() + +Return the list of additional archictectures to handle when dealing with noarch +packages. + +=cut + +sub get_extra_arches { + my ($self) = @_; + croak "Not a class method" unless ref $self; + return @{$self->{_extra_arches}}; +} + + +=head2 get_older_revisions($package, $target, $user_context, $app_context) + +Get all older revisions from a package found in its installation directory, as a +list of L<Youri::Package> objects. + +=cut + +sub get_older_revisions { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + print "Looking for package $package older revisions for $target\n" + if $self->{_verbose} > 0; + + return $self->get_revisions( + $package, + $target, + $user_context, + $app_context, + sub { return $package->compare($_[0]) > 0 } + ); +} + +=head2 get_last_older_revision($package, $target, $user_context, $app_context) + +Get last older revision from a package found in its installation directory, as a +single L<Youri::Package> object. + +=cut + +sub get_last_older_revision { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + print "Looking for package $package last older revision for $target\n" + if $self->{_verbose} > 0; + + return ( + $self->get_older_revisions( + $package, + $target, + $user_context, + $app_context + ) + )[0]; +} + +=head2 get_newer_revisions($package, $target, $user_context, $app_context) + +Get all newer revisions from a package found in its installation directory, as +a list of L<Youri::Package> objects. + +=cut + +sub get_newer_revisions { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + print "Looking for package $package newer revisions for $target\n" + if $self->{_verbose} > 0; + + return $self->get_revisions( + $package, + $target, + $user_context, + $app_context, + sub { return $_[0]->compare($package) > 0 } + ); +} + + +=head2 get_revisions($package, $target, $user_context, $app_context, $filter) + +Get all revisions from a package found in its installation directory, using an +optional filter, as a list of L<Youri::Package> objects. + +=cut + +sub get_revisions { + my ($self, $package, $target, $user_context, $app_context, $filter) = @_; + croak "Not a class method" unless ref $self; + print "Looking for package $package revisions for $target\n" + if $self->{_verbose} > 0; + + my @packages = + map { $self->get_package_class()->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path( + $package, + $target, + $user_context, + $app_context + ), + $self->get_package_class()->get_pattern( + $package->get_name(), + undef, + undef, + $package->get_arch(), + ) + ); + @packages = grep { $filter->($_) } @packages if $filter; + + return + sort { $b->compare($a) } # sort by revision order + @packages; +} + +=head2 get_obsoleted_packages($package, $target, $user_context, $app_context) + +Get all packages obsoleted by given one, as a list of L<Youri::Package> +objects. + +=cut + +sub get_obsoleted_packages { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + print "Looking for packages obsoleted by $package for $target\n" + if $self->{_verbose} > 0; + + my @packages; + foreach my $obsolete ($package->get_obsoletes()) { + my $pattern = $self->get_package_class()->get_pattern($obsolete->[Youri::Package::DEPENDENCY_NAME]); + my $range = $obsolete->[Youri::Package::DEPENDENCY_RANGE]; + push(@packages, + grep { $range ? $_->satisfy_range($range) : 1 } + map { $self->get_package_class()->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path( + $package, $target, + $user_context, + $app_context + ), + $pattern + ) + ); + } + + return @packages; +} + +=head2 get_replaced_packages($package, $target, $user_context, $app_context) + +Get all packages replaced by given one, as a list of L<Youri::Package> +objects. + +=cut + +sub get_replaced_packages { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + print "Looking for packages replaced by $package for $target\n" + if $self->{_verbose} > 0; + + my @list; + + # collect all older revisions + push(@list, $self->get_older_revisions( + $package, + $target, + $user_context, + $app_context + )); + + # noarch packages are potentially linked from other directories + if ($package->get_arch() eq 'noarch') { + foreach my $arch ($self->get_extra_arches()) { + push(@list, $self->get_older_revisions( + $package, + $target, + $user_context, + { arch => $arch } + )); + } + } + + # collect all obsoleted packages + push(@list, $self->get_obsoleted_packages( + $package, + $target, + $user_context, + $app_context + )); + + return @list; +} + +=head2 get_files($path, $pattern) + +Get all files found in a directory, using an optional filtering pattern +(applied to the whole file name), as a list of files. + +=cut + +sub get_files { + my ($self, $root, $path, $pattern) = @_; + croak "Not a class method" unless ref $self; + # debugging for bug 34999 + print "Looking for files matching $pattern in $root/$path\n"; +# if $self->{_verbose} > 1; + + my $grep = ""; + $grep = "-regextype posix-egrep -regex '.*\/$pattern'" if ($pattern); + # XXX: run find in a directory the user is guaranteed to have read + # permissions! find simply exits with error if the user doesn't have + # read permission on the *current* dir; as this code is run thru many + # sudo invocations, sometimes the user calling it has $HOME chmoded to + # 0700, making find fail when run as mandrake + # debugging for bug 34999 + print ".. running command: find -L $root/$path $grep -type f\n"; + my @files = map { chop; $_; } `cd && find -L $root/$path $grep -type f`; + die "FATAL: get_files(): find failed!" if ($?); + + return @files; +} + +=head2 get_install_root() + +Returns installation root + +=cut + +sub get_install_root { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_install_root}; +} + + +=head2 get_distribution_roots() + +Returns distribution roots (ie install_root + target + arch) +(it returns a list in case of noarch) + +=cut + +sub get_distribution_roots { + my ($self, $package, $target) = @_; + croak "Not a class method" unless ref $self; + + map { + $self->_get_dir($self->{_install_root}, $_); + } $self->get_distribution_paths($package, $target); +} + +=head2 get_install_dir($package, $target, $user_context, $app_context) + +Returns install destination directory for given L<Youri::Package> object +and given target. + +=cut + +sub get_install_dir { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + return $self->_get_dir( + $self->{_install_root}, + $self->get_install_path($package, $target, $user_context, $app_context) + ); +} + +=head2 get_archive_root() + +Returns archiving root + +=cut + +sub get_archive_root { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_archive_root}; +} + +=head2 get_archive_dir($package, $target, $user_context, $app_context) + +Returns archiving destination directory for given L<Youri::Package> object +and given target. + +=cut + +sub get_archive_dir { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + return $self->_get_dir( + $self->{_archive_root}, + $self->get_archive_path($package, $target, $user_context, $app_context) + ); +} + + +=head2 get_version_root() + +Returns versionning root + +=cut + +sub get_version_root { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_version_root}; +} + +=head2 get_version_dir($package, $target, $user_context, $app_context) + +Returns versioning destination directory for given L<Youri::Package> +object and given target. + +=cut + +sub get_version_dir { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + return $self->_get_dir( + $self->{_version_root}, + $self->get_version_path($package, $target, $user_context, $app_context) + ); +} + +sub _get_dir { + my ($self, $root, $path) = @_; + + return substr($path, 0, 1) eq '/' ? + $path : + $root . '/' . $path; +} + +=head2 get_install_file($package, $target, $user_context, $app_context) + +Returns install destination file for given L<Youri::Package> object and +given target. + +=cut + +sub get_install_file { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + return + $self->get_install_dir($package, $target, $user_context, $app_context) . + '/' . + $package->get_file_name(); +} + +=head2 get_install_path($package, $target, $user_context, $app_context) + +Returns installation destination path (relative to repository root) for given +L<Youri::Package> object and given target. + +=head2 get_archive_path($package, $target, $user_context, $app_context) + +Returns archiving destination path (relative to repository root) for given +L<Youri::Package> object and given target. + +=head2 get_version_path($package, $target, $user_context, $app_context) + +Returns versioning destination path (relative to repository root) for given +L<Youri::Package> object and given target. + +=head1 SUBCLASSING + +The following methods have to be implemented: + +=over + +=item get_install_path + +=item get_archive_path + +=item get_version_path + +=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/Repository/Mandriva_upload.pm b/lib/Youri/Repository/Mandriva_upload.pm new file mode 100644 index 0000000..d34bb80 --- /dev/null +++ b/lib/Youri/Repository/Mandriva_upload.pm @@ -0,0 +1,546 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/RSS.pm 857 2006-01-29T10:15:43.298856Z guillaume $ +package Youri::Repository::Mandriva_upload; + +=head1 NAME + +Youri::Repository::PLF - PLF repository implementation + +=head1 DESCRIPTION + +This module implements PLF repository. + +=cut + +use warnings; +use strict; +use Carp; +use Memoize; +use File::Find 'find'; +use base qw/Youri::Repository/; +use MDV::Distribconf::Build; +use SVN::Client; + +use constant { + PACKAGE_CLASS => 'Youri::Package::URPM', + PACKAGE_CHARSET => 'utf8' +}; + +memoize('_get_media_config'); + +my %translate_arch = ( + i386 => 'i586', + sparc64 => 'sparcv9', +); + +sub _init { + my $self = shift; + my %options = ( + noarch => 'i586', # noarch packages policy + src => 'i586', + install_root => '', + test => 0, # test mode + verbose => 0, # verbose mode + queue => '', + rejected => '', + @_ + ); + foreach my $var ('upload_state') { + $self->{"_$var"} = []; + foreach my $value (split ' ', $options{$var}) { + push @{$self->{"_$var"}}, $value + } + } + print "Initializing repository\n"; + foreach my $v ('rejected', 'svn', 'queue', 'noarch', 'install_root', 'upload_root', 'verbose') { + $self->{"_$v"} = $options{$v} + } + foreach my $target (@{$options{targets}}) { + $self->{$target} = []; + print "Adding $target ($options{$target}{arch})\n" if $self->{_verbose}; + foreach my $value (split ' ', $options{$target}{arch}) { + push @{$self->{_arch}{$target}}, $value; + push @{$self->{_extra_arches}}, $value + } + } + $self +} + +sub get_group_id { + my ($user) = @_; + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); + $year+=1900; + $mon++; + my $hostname = `hostname`; + my ($host) = $hostname =~ /([^.]*)/; + sprintf "$year%02d%02d%02d%02d%02d.$user.$host.${$}_", $mon, $mday, $hour, $min, $sec; +} + +sub get_target_arch { + my ($self, $target) = $_; + return $self->{_arch}{$target} +} + +sub set_arch_changed { + my ($self, $target, $arch) = @_; + if ($arch eq 'noarch') { + $self->{_arch_changed}{$_} = 1 foreach @{$self->{_arch}{$target}} + } elsif ($arch eq 'src') { + $self->{_arch_changed} = $self->{_src} + } else { + $self->{_arch_changed}{$arch} = 1 + } +} + +sub get_arch_changed { + my ($self, $target) = @_; + return [ keys %{$self->{_arch_changed}} ] +} + +sub set_install_dir_changed { + my ($self, $install_dir) = @_; + $self->{_install_dir_changed}{$install_dir} = 1; +} + +sub get_install_dir_changed { + my ($self) = @_; + return [ keys %{$self->{_install_dir_changed}} ]; +} + +sub _get_media_config { + my ($self, $target) = @_; + my %media; + my $real_target = $target; + $real_target =~ s/_force//; + foreach my $arch (@{$self->{_arch}{$target}}) { + my $root = "$self->{_install_root}/$real_target/$arch"; + my $distrib = MDV::Distribconf::Build->new($root); + print "Getting media config from $root\n" if $self->{_verbose}; + $self->{distrib}{$arch} = $distrib; + $distrib->loadtree or die "$root does not seem to be a distribution tree\n"; + $distrib->parse_mediacfg; + foreach my $media ($distrib->listmedia) { + my $rpms = $distrib->getvalue($media, 'rpms'); + my $debug_for = $distrib->getvalue($media, 'debug_for'); + my $srpms = $distrib->getvalue($media, 'srpms'); + my $path = $distrib->getfullpath($media, 'path'); + if (!$rpms) { + if (-d $path) { + print "MEDIA defining $media in $path\n" if $self->{_verbose} > 1; + $media{$arch}{$media} = $path + } else { + print "ERROR $path does not exist for media $media on $arch\n" + } + } else { + my ($media) = split ' ', $rpms; + if (-d $path) { + print "MEDIA defining SOURCE media for $media in $path\n" if $self->{_verbose} > 1; + $media{src}{$media} = $path + } else { + print "ERROR $path does not exist for source media $media on $arch\n" + } + } + } + } + \%media +} + +sub get_package_class { + return PACKAGE_CLASS; +} + +sub get_package_charset { + return PACKAGE_CHARSET; +} + +sub get_upload_dir { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + my $arch = $package->get_arch(); + return + $self->{_upload_root} . + "/$self->{_queue}/$target/" . + _get_section($self, $package, $target, $user_context, $app_context) . + '/' . + ($user_context->{prefix} ? '' : get_group_id($user_context->{user})) +} + +sub get_install_path { + my ($self, $package, $target, $user_context, $app_context) = @_; + + return $self->_get_path($package, $target, $user_context, $app_context); +} + + +sub get_distribution_paths { + my ($self, $package, $target) = @_; + + return $self->_get_distribution_paths($package, $target); +} + +sub get_archive_path { + my ($self, $package, $target, $user_context, $app_context) = @_; + + return $self->_get_path($package, $target, $user_context, $app_context); +} + +sub get_reject_path { + my ($self, $package, $target, $user_context, $app_context) = @_; + + return $self->{_rejected}; +} + + +sub _get_path { + my ($self, $package, $target, $user_context, $app_context) = @_; + + my $section = $self->_get_section($package, $target, $user_context, $app_context); + my $arch = $app_context->{arch} || $package->get_arch(); + $arch = $translate_arch{$arch} || $arch; + if ($arch eq 'noarch') { + $arch = $self->{_noarch} + } elsif ($arch eq 'src') { + return "$target/SRPMS/$section" + } + "$target/$arch/media/$section" +} + +sub _get_distribution_paths { + my ($self, $package, $target) = @_; + + my $arch = $package->get_arch(); + $arch = $translate_arch{$arch} || $arch; + if ($arch eq 'noarch') { + map { "$target/$_" } $self->get_extra_arches; + } elsif ($arch eq 'src') { + die "no way to get distribution path using a $arch package"; + } else { + "$target/$arch"; + } +} + +sub get_arch { + my ($self, $package, $target, $user_context, $app_context) = @_; + my $arch = $package->get_arch(); + $arch = $translate_arch{$arch} || $arch; + if ($arch eq 'noarch') { + $arch = $self->{_noarch} + } + $arch +} + +sub get_version_path { + my ($self, $package, $target, $user_context, $app_context) = @_; + + my $section = $self->_get_section($package, $target, $user_context, $app_context); + + return "$self->{_module}/$section"; +} + +=head2 get_replaced_packages($package, $target, $user_context, $app_context) + +Overrides parent method to add libified packages. + +=cut + +sub get_replaced_packages { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + my @replaced_packages = + $self->SUPER::get_replaced_packages($package, $target, $user_context, $app_context); + + # mandriva lib policy: + # library package names change with revision, making mandatory to + # duplicate older revisions search with a custom pattern + my $name = $package->get_name(); + if ($name =~ /^(lib\w+[a-zA-Z_])[\d_\.]+([-\w]*)$/) { + push(@replaced_packages, + grep { $package->compare($_) > 0 } + map { PACKAGE_CLASS->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path($package, $target, $user_context, $app_context), + PACKAGE_CLASS->get_pattern( + $1 . '[\d_\.]+' . $2, # custom name pattern + undef, + undef, + $package->get_arch() + ), + ) + ); + } + + # kernel packages have the version in the name + # binary dkms built for old kernels have to be removed too + if ($name =~ /^kernel-([^\d]*-)?([\d.]*)-(.*)$/) { # "desktop", "2.6.28", "2mnb" + push(@replaced_packages, + map { PACKAGE_CLASS->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path($package, $target, $user_context, $app_context), + PACKAGE_CLASS->get_pattern( + '(kernel-' . $1 . '\d.*|.*-kernel-[\d.]*-' . $1 . '\d.*)', + undef, + undef, + $package->get_arch() + ), + ) + ); + } + + return @replaced_packages; + +} + +sub _get_main_section { + my ($self, $package, $target, $user_context, $app_context) = @_; + + my $section = $self->_get_section($package, $target, $user_context, $app_context); + my ($main_section) = $section =~ m,^([^/]+),; + $main_section +} + +sub _get_section { + my ($self, $package, $target, $user_context, $app_context) = @_; + + my $name = $package->get_name(); + my $cname = $package->get_canonical_name(); + my $version = $package->get_version(); + my $release = $package->get_release(); + my $section = $user_context->{section}; + my $media = $self->_get_media_config($target); + my $arch = $package->get_arch(); + my $file = $package->as_file(); + $file =~ s,/+,/,g; # unneeded? + # FIXME: use $self->get_arch() + $arch = $self->{_noarch} if $arch eq 'noarch'; + $arch = $translate_arch{$arch} || $arch; + + if (!$section) { + $section = $self->{packages}{$file}{section}; + print "Section undefined, repository says it is '$section' for '$file'\n" if $self->{_verbose}; + } + if ($section && $section !~ /debug_/ && $package->is_debug()) { + $section = "debug_$section" + } + + # if have section already, check if it exists, and may return immediately + if ($section) { + print "Using requested section $section\n"; + if ($media->{$arch}{$section}) { + return $section + } else { + die "FATAL youri: unknown section $section for target $target for arch $arch\n" + } + } + # else, try to find section automatically + + # pattern for search of src package with specific version-release, + # should be searched first, because we prefer to find the precise + # section a package is already in + my $specific_source_pattern = PACKAGE_CLASS->get_pattern( + $cname, + $version, + $release, + 'src' + ); + + my $source_pattern = PACKAGE_CLASS->get_pattern( + $cname, + undef, + undef, + 'src' + ); + + # if a media has no source media configured, or if it is a debug + # package, we search in binary media + + # pattern for search when a binary media has no src media configured + my $specific_binary_pattern = PACKAGE_CLASS->get_pattern( + $name, + $version, + $release, + $arch + ); + + # last resort pattern: previous existing binary packages + my $binary_pattern = PACKAGE_CLASS->get_pattern( + $name, + undef, + undef, + $arch + ); + + # first try to find section for the specific version, as it is possibly already there; + # this is the case for when called in Youri::Submit::Action::Archive, to find the + # section the package got installed + print "Looking for package $name with version $version-$release\n"; + foreach my $m (keys %{$media->{$arch}}) { + print " .. section '$m' path '".$media->{$arch}{$m}."'\n" if $self->{_verbose}; + # - prefer source for non-debug packages, use binary if there is no source media configured + # - debug packages must be searched in binary medias, due to their + # src section != binary section; NOTE: should/need we search in + # src medias and add the 'debug_' prefix? + if (!$package->is_debug() && $media->{src}{$m}) { + next unless $self->get_files('', $media->{src}{$m}, $specific_source_pattern); + } else { + next unless $self->get_files('', $media->{$arch}{$m}, $specific_binary_pattern); + } + $section = $m; + last; + } + + # if still not found, try finding any version of the package in a + # /release subsection (safe default: /release is default for cooker, + # should be locked for released distros, and we don't risk wrongly + # choosing /backports, /testing, or /updates); + # this is the case for when called at submit, to find the section where + # the package already resides + if (!$section) { + # debug packages should be found by previous specific version search + # NOTE: as above, should/need we search here and add the 'debug_' prefix? + # ... probably... as at least mdv-youri-submit-force will process debug packages + if ($package->is_debug() && $self->{_verbose}) { + print "Warning: debug package $name with version $version-$release not found.\n"; + } + + print "Warning: Looking for any section with a package $name of any version\n"; + foreach my $m (keys %{$media->{$arch}}) { + print " .. section '$m' path '".$media->{$arch}{$m}."'\n" if $self->{_verbose}; + # NOTE: !$package->is_debug() test is here to prevent when above FATAL error is removed + next if $m !~ /release/ || ($m =~ /debug/ && !$package->is_debug()); + # - prefer source + if ($media->{src}{$m}) { + next unless $self->get_files('', $media->{src}{$m}, $source_pattern); + } else { + next unless $self->get_files('', $media->{$arch}{$m}, $binary_pattern); + } + $section = $m; + last; + } + } + + # FIXME: doing this here is wrong; this way the caller can never know if + # a section was actually found or not; should return undef and let the + # caller set a default (Note: IIRC PLF|Zarb has this right, see there) -spuk + print STDERR "Warning: Can't guess destination: section missing, defaulting to contrib/release\n" unless $section; + $section ||= 'contrib/release'; + + # next time we don't need to search everything again + $self->{packages}{$file}{section} = $section; + + print "Section is '$section'.\n"; + + return $section; +} + +sub get_upload_newer_revisions { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + my $arch = $package->get_arch(); + my $name = $package->get_full_name; + $name =~ s/^\@\d+://; + my $pattern = $self->get_package_class()->get_pattern($package->get_name(), undef, undef, $arch); + my $media = $self->_get_media_config($target); + my @packages; + foreach my $state (@{$self->{_upload_state}}) { + foreach my $m (keys %{$media->{$arch}}) { + my $path = "$self->{_upload_root}/$state/$target/$m"; + print "Looking for package $package revisions for $target in $path (pattern $pattern)\n" if $self->{_verbose}; + find( + sub { + s/\d{14}\.[^.]*\.[^.]*\.\d+_//; + s/^\@\d+://; + return if ! /^$pattern/; + return if /\.info$/; + print "Find $_\n"; + push @packages, $File::Find::name if $package->check_ranges_compatibility("== $name", "< $_") + }, $path); + } + } + return + @packages; +} + +sub package_in_svn { + my ($self, $srpm_name) = @_; + my $ctx = new SVN::Client( + auth => [SVN::Client::get_simple_provider(), + SVN::Client::get_simple_prompt_provider(\&simple_prompt,2), + SVN::Client::get_username_provider()] + ); + + my $svn_entry = $ctx->ls("$self->{_svn}/$srpm_name", 'HEAD', 0); + if ($svn_entry) { + print "Package $srpm_name is in the SVN\n"; + return 1 + } +} + +sub get_svn_url { + my ($self) = @_; + $self->{_svn} +} + +sub get_revisions { + my ($self, $package, $target, $user_context, $app_context, $filter) = @_; + croak "Not a class method" unless ref $self; + print "Looking for package $package revisions for $target\n" if $self->{_verbose} > 0; + + my $arch = $app_context->{arch} || $user_context->{arch} || $package->get_arch(); + my $media_arch = $arch eq 'noarch' ? $self->{_noarch} : $arch; + my $path = $arch eq 'src' ? "$target/SRPMS/" : "$target/$media_arch/media"; + my $media = $self->_get_section($package, $target, $user_context, $app_context); + my $name = $package->get_name(); + my @packages = map { $self->get_package_class()->new(file => $_) } + $self->get_files( + $self->{_install_root}, + "$path/$media", + $self->get_package_class()->get_pattern( + $name, + undef, + undef, + $package->get_arch(), + ) + ); + + @packages = grep { $filter->($_) } @packages if $filter; + + return + sort { $b->compare($a) } # sort by revision order + @packages; +} + +sub reject { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + +} + +sub get_archive_dir { + my ($self, $package, $target, $user_context, $app_context) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_archive_root} +} + + +# 20060801 warly +# +# Upload steps +# SRPMS are uploaded in /home/mandrake/uploads/todo/$target/$media/group_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/Repository/Mandriva_upload_pre.pm b/lib/Youri/Repository/Mandriva_upload_pre.pm new file mode 100644 index 0000000..52ecc15 --- /dev/null +++ b/lib/Youri/Repository/Mandriva_upload_pre.pm @@ -0,0 +1,276 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/RSS.pm 857 2006-01-29T10:15:43.298856Z guillaume $ +package Youri::Repository::Mandriva_upload_pre; + +=head1 NAME + +Youri::Repository::PLF - PLF repository implementation + +=head1 DESCRIPTION + +This module implements PLF repository. + +=cut + +use warnings; +use strict; +use Carp; +use Memoize; +use File::Find 'find'; +use base qw/Youri::Repository/; +use SVN::Client; +use constant { + PACKAGE_CLASS => 'Youri::Package::URPM', + PACKAGE_CHARSET => 'utf8' +}; + +memoize('_get_section'); + +my @pkgsections = qw/core nonfree tainted/; + +sub _init { + my $self = shift; + my %options = ( + module => 'SPECS', # CVS module + noarch => 'i586', # noarch packages policy + svn => '', + upload_root => '', + @_ + ); + + $self->{_module} = $options{module}; + $self->{_noarch} = $options{noarch}; + $self->{_svn} = $options{svn}; + $self->{_upload_root} = $options{upload_root}; + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); + $year+=1900; + my $hostname = `hostname`; + my ($host) = $hostname =~ /([^.]*)/; + $self->{group_dir} = sprintf "$ENV{SUDO_USER}.$host.$$.$year%02d%02d%02d%02d%02d", $mon, $mday, $hour, $min, $sec; +} + +sub get_package_class { + return PACKAGE_CLASS; +} + +sub package_in_svn { + my ($self, $srpm_name) = @_; + my $ctx = new SVN::Client( + auth => [SVN::Client::get_simple_provider(), + SVN::Client::get_simple_prompt_provider(\&simple_prompt,2), + SVN::Client::get_username_provider()] + ); + + my $svn_entry = $ctx->ls("$self->{_svn}/", 'HEAD', 0); + foreach (keys %{$svn_entry}) { + if ($srpm_name eq $_) { + print "Package $_ is in the SVN\n"; + return 1 + } + } +} + +sub get_svn_url { + my ($self) = @_; + $self->{_svn} +} + +sub get_revisions { + my ($self, $package, $target, $define, $filter) = @_; + croak "Not a class method" unless ref $self; + print "Looking for package $package revisions for $target\n" + if $self->{_verbose} > 0; + + my $arch = $define->{arch} || $package->get_arch; + if ($arch eq 'src') { + $arch = 'SRPMS' + } else { + $arch .= '/media' + } + my @packages; + foreach my $dir (@pkgsections) { + print "Looking into $self->{_install_root}/$target/$arch/$dir/release\n"; + push @packages, + map { $self->get_package_class()->new(file => $_) } + $self->get_files( + $self->{_install_root}, + "$target/$arch/$dir/release" , + $self->get_package_class()->get_pattern($package->get_name(),undef, undef, $arch) + ); + } + + @packages = grep { $filter->($_) } @packages if $filter; + + return + sort { $b->compare($a) } # sort by revision order + @packages; +} + +sub get_package_charset { + return PACKAGE_CHARSET; +} + +sub get_upload_dir { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + my $arch = $package->get_arch(); + my $section = $self->_get_section($package, $target, $define); + my $media_path = $section eq 'main' ? $target : $target =~ /^cooker/ ? "contrib" : "$target/contrib"; + my $arch_path = $arch eq 'src' ? 'SRPMS' : 'RPMS'; + my $force = $target =~ /_force/ ? 'force' : ''; + $self->{_upload_root} . "/$media_path/$force/$arch_path/" +} + +sub get_arch { + my ($self, $package, $target, $define) = @_; + my $arch = $package->get_arch(); + if ($arch eq 'noarch') { + $arch = $self->{_noarch} + } + $arch +} + +sub get_install_path { + my ($self, $package, $target, $define) = @_; + + return $self->_get_path($package, $target, $define); +} + +sub get_archive_path { + my ($self, $package, $target, $define) = @_; + + return $self->_get_path($package, $target, $define); +} + +sub _get_path { + my ($self, $package, $target, $define) = @_; + + my $arch = $package->get_arch; + if ($arch eq 'src') { + $arch = 'SRPMS' + } else { + $arch .= '/media' + } + my $section = $self->_get_section($package, $target, $define); + + return "$target/$arch/$section/release/"; +} + + +sub get_version_path { + my ($self, $package, $target, $define) = @_; + + my $section = $self->_get_section($package, $target, $define); + + return "$self->{_module}/$section/release/"; +} + +=head2 get_replaced_packages($package, $target, $define) + +Overrides parent method to add libified packages. + +=cut + +sub get_replaced_packages { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @replaced_packages = + $self->SUPER::get_replaced_packages($package, $target, $define); + + # mandriva lib policy: + # library package names change with revision, making mandatory to + # duplicate older revisions search with a custom pattern + my $name = $package->get_name(); + if ($name =~ /^(lib\w+[a-zA-Z_])[\d_\.]+([-\w]*)$/) { + push(@replaced_packages, + grep { $package->compare($_) > 0 } + map { PACKAGE_CLASS->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path($package, $target, $define), + PACKAGE_CLASS->get_pattern( + $1 . '[\d_\.]+' . $2, # custom name pattern + undef, + undef, + $package->get_arch() + ), + ) + ); + } + + return @replaced_packages; + +} + +sub _get_section { + my ($self, $package, $target, $define) = @_; + + my $section; + + # try to find section automatically + my $arch = $package->get_arch(); + $arch = $self->{_noarch} if $arch eq 'noarch'; + + my $source_pattern = PACKAGE_CLASS->get_pattern( + $package->get_canonical_name(), + undef, + undef, + 'src' + ); + + my $binary_pattern = PACKAGE_CLASS->get_pattern( + $package->get_name(), + undef, + undef, + $arch + ); + + # for each potential section, try to match + # a suitable source patten in source directory + # a suitable binary patten in binary directory + foreach my $dir (@pkgsections) { + next unless + $self->get_files( + $self->{_install_root}, + "$target/SRPMS/$dir/release", + $source_pattern + ) || $self->get_files( + $self->{_install_root}, + "$target/$arch/media/$dir/release", + $binary_pattern + ); + print "Section is $dir\n"; + $section = $dir; + last; + } + + # use defined section if not found + $section = $define->{section} unless $section; + + $section || 'contrib' +} + +sub get_upload_newer_revisions { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + my $arch = $package->get_arch(); + my $pattern = $self->get_package_class()->get_pattern($package->get_name(), undef, undef, $arch); + print "Looking for package $package revisions for $target in $self->{_upload_root} (pattern $pattern)\n"; + my @packages; + foreach my $dir ('cooker', 'contrib') { + find(sub { return if ! /^$pattern/; print "Find $_\n"; push @packages, $File::Find::name if $package->compare($self->get_package_class()->new(file => $File::Find::name)) <= 0 }, "$self->{_upload_root}/$dir"); + } + return + @packages; +} + +=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/Repository/PLF.pm b/lib/Youri/Repository/PLF.pm new file mode 100644 index 0000000..c260379 --- /dev/null +++ b/lib/Youri/Repository/PLF.pm @@ -0,0 +1,196 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/RSS.pm 857 2006-01-29T10:15:43.298856Z guillaume $ +package Youri::Repository::PLF; + +=head1 NAME + +Youri::Repository::PLF - PLF repository implementation + +=head1 DESCRIPTION + +This module implements PLF repository. + +=cut + +use warnings; +use strict; +use Carp; +use Memoize; +use base qw/Youri::Repository/; +use constant { + PACKAGE_CLASS => 'Youri::Package::URPM', + PACKAGE_CHARSET => 'utf8' +}; + +memoize('_get_section'); + + +sub _init { + my $self = shift; + my %options = ( + module => 'SPECS', # CVS module + noarch => 'noarch', # noarch packages policy + @_ + ); + + $self->{_module} = $options{module}; + $self->{_noarch} = $options{noarch}; +} + +sub get_package_class { + return PACKAGE_CLASS; +} + +sub get_package_charset { + return PACKAGE_CHARSET; +} + +sub get_install_path { + my ($self, $package, $target, $define) = @_; + + return $self->_get_path($package, $target, $define); +} + +sub get_archive_path { + my ($self, $package, $target, $define) = @_; + + return $self->_get_path($package, $target, $define); +} + +sub _get_path { + my ($self, $package, $target, $define) = @_; + + my $section = $self->_get_section($package, $target, $define); + + my $subpath = $self->_get_subpath($package, $target); + + return "$section/$subpath"; +} + + +sub get_version_path { + my ($self, $package, $target, $define) = @_; + + my $section = $self->_get_section($package, $target, $define); + + return "$self->{_module}/$section"; +} + +=head2 get_replaced_packages($package, $target, $define) + +Overrides parent method to add libified packages. + +=cut + +sub get_replaced_packages { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @replaced_packages = + $self->SUPER::get_replaced_packages($package, $target, $define); + + # mandriva lib policy: + # library package names change with revision, making mandatory to + # duplicate older revisions search with a custom pattern + my $name = $package->get_name(); + if ($name =~ /^(lib\w+[a-zA-Z_])[\d_\.]+([-\w]*)$/) { + push(@replaced_packages, + grep { $package->compare($_) > 0 } + map { PACKAGE_CLASS->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path($package, $target, $define), + PACKAGE_CLASS->get_pattern( + $1 . '[\d_\.]+' . $2, # custom name pattern + undef, + undef, + $package->get_arch() + ), + ) + ); + } + + return @replaced_packages; + +} + +sub _get_section { + my ($self, $package, $target, $define) = @_; + + my $section; + + # try to find section automatically + my $arch = $package->get_arch(); + + my $source_pattern = PACKAGE_CLASS->get_pattern( + $package->get_canonical_name(), + undef, + undef, + 'src' + ); + + my $binary_pattern = PACKAGE_CLASS->get_pattern( + $package->get_name(), + undef, + undef, + $arch + ); + + my $source_subpath = $self->_get_subpath($package, $target, 'src'); + my $binary_subpath = $self->_get_subpath($package, $target, $arch); + + # for each potential section, try to match + # a suitable source patten in source directory + # a suitable binary patten in binary directory + foreach my $dir (qw/free non-free/) { + next unless + $self->get_files( + $self->{_install_root}, + "$dir/$source_subpath", + $source_pattern + ) || $self->get_files( + $self->{_install_root}, + "$dir/$binary_subpath", + $binary_pattern + ); + $section = $dir; + last; + } + + # use defined section if not found + $section = $define->{section} unless $section; + + die "Can't guess destination: section missing" unless $section; + + return $section; +} + +sub _get_subpath { + my ($self, $package, $target, $arch) = @_; + + my $subpath; + + # use package arch if not specified + $arch = $package->get_arch() unless $arch; + + if ($arch eq 'src') { + $subpath = 'src'; + } else { + if ($arch eq 'noarch') { + $subpath = "$target/$self->{_noarch}"; + } else { + $subpath = "$target/$arch"; + } + } + + return $subpath; +} + +=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/Utils.pm b/lib/Youri/Utils.pm new file mode 100644 index 0000000..f22796a --- /dev/null +++ b/lib/Youri/Utils.pm @@ -0,0 +1,98 @@ +# $Id: Utils.pm 1713 2006-10-16 16:39:53Z warly $ +package Youri::Utils; + +=head1 NAME + +Youri::Utils - Youri shared functions + +=head1 DESCRIPTION + +This module implement some helper functions for all youri applications. + +=cut + +use base qw(Exporter); +use Carp; +use strict; +use warnings; + +our @EXPORT = qw( + create_instance + load_class + add2hash + add2hash_ +); + +=head2 create_instance($class, $config, $options) + +Create an instance from a plugin implementing given interface, using given +configuration and local options. +Returns a plugin instance, or undef if something went wrong. + +=cut + +sub create_instance { + my ($interface, $config, $options) = @_; + + croak 'No interface given' unless $interface; + croak 'No config given' unless $config; + + my $class = $config->{class}; + if (!$class) { + carp "No class given, can't load plugin"; + return; + } + + # ensure loaded + load_class($class); + + # check interface + if (!$class->isa($interface)) { + carp "$class is not a $interface"; + return; + } + + # instantiate + no strict 'refs'; + + return $class->new( + $config->{options} ? %{$config->{options}} : (), + $options ? %{$options} : (), + ); +} + +sub load_class { + my ($class) = @_; + + $class .= '.pm'; + $class =~ s/::/\//g; + require $class; +} + +# structure helpers + +sub add2hash { + my ($a, $b) = @_; + while (my ($k, $v) = each %{$b || {}}) { + $a->{$k} ||= $v; + } + return $a; +} + +sub add2hash_ { + my ($a, $b) = @_; + while (my ($k, $v) = each %{$b || {}}) { + exists $a->{$k} or $a->{$k} = $v; + } + return $a; +} + +=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; |