diff options
Diffstat (limited to 'lib')
69 files changed, 9447 insertions, 0 deletions
diff --git a/lib/Youri/Bugzilla.pm b/lib/Youri/Bugzilla.pm new file mode 100644 index 0000000..4ed30fd --- /dev/null +++ b/lib/Youri/Bugzilla.pm @@ -0,0 +1,482 @@ +# $Id: Bugzilla.pm 832 2006-04-03 13:32:37Z guillomovitch $ +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..6295940 --- /dev/null +++ b/lib/Youri/Check/Input.pm @@ -0,0 +1,120 @@ +# $Id: Input.pm 868 2006-04-11 20:35:09Z guillomovitch $ +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..1b80d62 --- /dev/null +++ b/lib/Youri/Check/Input/Age.pm @@ -0,0 +1,110 @@ +# $Id: Age.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..fc93af8 --- /dev/null +++ b/lib/Youri/Check/Input/Build.pm @@ -0,0 +1,128 @@ +# $Id: Build.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..be13ac7 --- /dev/null +++ b/lib/Youri/Check/Input/Build/Source.pm @@ -0,0 +1,109 @@ +# $Id: Source.pm 868 2006-04-11 20:35:09Z guillomovitch $ +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..1f01645 --- /dev/null +++ b/lib/Youri/Check/Input/Build/Source/LBD.pm @@ -0,0 +1,135 @@ +# $Id: LBD.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..9ffc986 --- /dev/null +++ b/lib/Youri/Check/Input/Conflicts.pm @@ -0,0 +1,231 @@ +# $Id: Conflicts.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..5533ef4 --- /dev/null +++ b/lib/Youri/Check/Input/Dependencies.pm @@ -0,0 +1,162 @@ +# $Id: Dependencies.pm 875 2006-04-16 12:02:22Z guillomovitch $ +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..7b6a735 --- /dev/null +++ b/lib/Youri/Check/Input/Rpmlint.pm @@ -0,0 +1,113 @@ +# $Id: Rpmlint.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..2d21cb3 --- /dev/null +++ b/lib/Youri/Check/Input/Updates.pm @@ -0,0 +1,275 @@ +# $Id: Updates.pm 915 2006-05-23 20:01:49Z pterjan $ +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..1f671bd --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source.pm @@ -0,0 +1,240 @@ +# $Id: Source.pm 897 2006-04-20 21:57:56Z guillomovitch $ +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..99f155f --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/CPAN.pm @@ -0,0 +1,75 @@ +# $Id: CPAN.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..c930a10 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Debian.pm @@ -0,0 +1,82 @@ +# $Id: Debian.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..cbe255a --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Fedora.pm @@ -0,0 +1,63 @@ +# $Id: Fedora.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..53672f0 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm @@ -0,0 +1,111 @@ +# $Id: Freshmeat.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..9b2473e --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Gentoo.pm @@ -0,0 +1,75 @@ +# $Id: Gentoo.pm 885 2006-04-17 22:25:00Z guillomovitch $ +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..8f820c5 --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/RAA.pm @@ -0,0 +1,121 @@ +# $Id: RAA.pm 902 2006-04-21 21:44:25Z guillomovitch $ +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..9a3305c --- /dev/null +++ b/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm @@ -0,0 +1,103 @@ +# $Id: Sourceforge.pm 908 2006-05-12 21:16:08Z pterjan $ +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..45ac750 --- /dev/null +++ b/lib/Youri/Check/Maintainer/Preferences.pm @@ -0,0 +1,80 @@ +# $Id: Preferences.pm 897 2006-04-20 21:57:56Z guillomovitch $ +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..11f9763 --- /dev/null +++ b/lib/Youri/Check/Maintainer/Preferences/File.pm @@ -0,0 +1,87 @@ +# $Id: File.pm 897 2006-04-20 21:57:56Z guillomovitch $ +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..3b95560 --- /dev/null +++ b/lib/Youri/Check/Maintainer/Resolver.pm @@ -0,0 +1,86 @@ +# $Id: Resolver.pm 883 2006-04-17 22:24:21Z guillomovitch $ +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..7ff611d --- /dev/null +++ b/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm @@ -0,0 +1,100 @@ +# $Id: Bugzilla.pm 883 2006-04-17 22:24:21Z guillomovitch $ +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..4fb86b5 --- /dev/null +++ b/lib/Youri/Check/Maintainer/Resolver/CGI.pm @@ -0,0 +1,79 @@ +# $Id: CGI.pm 895 2006-04-20 21:57:41Z guillomovitch $ +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..c3038d7 --- /dev/null +++ b/lib/Youri/Check/Output.pm @@ -0,0 +1,190 @@ +# $Id: Output.pm 868 2006-04-11 20:35:09Z guillomovitch $ +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..5413a4b --- /dev/null +++ b/lib/Youri/Check/Output/File/Format/HTML.pm @@ -0,0 +1,222 @@ +# $Id: HTML.pm 876 2006-04-16 12:07:20Z guillomovitch $ +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..458c75e --- /dev/null +++ b/lib/Youri/Check/Output/File/Format/Text.pm @@ -0,0 +1,88 @@ +# $Id: Text.pm 867 2006-04-11 20:34:56Z guillomovitch $ +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..5edf024 --- /dev/null +++ b/lib/Youri/Check/Output/Mail.pm @@ -0,0 +1,156 @@ +# $Id: Mail.pm 947 2006-07-05 14:24:17Z guillomovitch $ +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..dab63aa --- /dev/null +++ b/lib/Youri/Config.pm @@ -0,0 +1,235 @@ +# $Id: Config.pm 961 2006-07-11 09:56:51Z guillomovitch $ +package Youri::Config; + +=head1 NAME + +Youri::Config - Youri configuration handler + +=head1 SYNOPSIS + + use Youri::Config; + + my $config = Youri::Config->new( + command_spec => [ + 'help|h!', + ], + file_spec => [ + 'foo=s', + ], + directories => [ '/etc/youri', "$ENV{HOME}/.youri" ], + file_name => 'app.conf', + caller => $0, + ); + + # get configuration directive + my $foo = $config->get('foo'); + + # get configuration section + my %bar = $config->get_section('bar'); + +=head1 DESCRIPTION + +This class handle configuration for all YOURI tools. + +It uses distinct command line and config files specification, but merges the +two inputs transparently, command line directives overriding config file +directives with the same name. + +Given directories are scanned for a file with given name, and only the first +one found is used. If B<--config> argument is given on command line, no +scanning occurs. If no readable file is found, an exception is thrown. + +==head1 FORMAT + +The file format used is the one from AppConfig, with the additional ability to +use YAML. Here is an exemple configuration file: + + [updates] + class = Youri::Check::Check::Updates + grabbers = <<EOF + --- #YAML:1.0 + debian: + class: Youri::Check::Check::Updates::Debian + aliases: + fuse: ~ + cpan: + class: Youri::Check::Check::Updates::CPAN + fedora: + class: Youri::Check::Check::Updates::Fedora + gentoo: + class: Youri::Check::Check::Updates::Gentoo + freshmeat: + class: Youri::Check::Check::Updates::Freshmeat + aliases: + fuse: fuse-emulator + EOF + +As a side-effect of using YAML, the use of character '~' anywhere is prohibited. +Use ${HOME} instead. + +=head1 SEE ALSO + +AppConfig, YAML + +=cut + +use strict; +use warnings; +use AppConfig qw/:argcount :expand/; +use File::Spec; +use Pod::Usage; +use Carp; +use YAML; + +sub new { + my ($class, %options) = @_; + + my ($command_config, $file_config); + + # process command line + if ($options{command_spec}) { + $command_config = AppConfig->new( + { + CREATE => 1, + GLOBAL => { + DEFAULT => '', + EXPAND => EXPAND_VAR | EXPAND_ENV, + ARGCOUNT => ARGCOUNT_ONE, + } + }, + @{$options{command_spec}} + ); + $command_config->args(); + + pod2usage( + -input => $options{caller}, + -verbose => 0 + ) if $command_config->get('help'); + } + + # process config file + $file_config = AppConfig->new( + { + CREATE => 1, + GLOBAL => { + DEFAULT => '', + EXPAND => EXPAND_VAR | EXPAND_ENV, + ARGCOUNT => ARGCOUNT_ONE, + } + }, + @{$options{file_spec}} + ); + + # find configuration file to use + my $main_file; + + if ($command_config) { + my $file = $command_config->get('config'); + if ($file) { + if (! -f $file) { + carp "Non-existing file $file, skipping"; + } elsif (! -r $file) { + carp "Non-readable file $file, skipping"; + } else { + $main_file = $file; + } + }; + } + + unless ($main_file) { + foreach my $directory (@{$options{directories}}) { + my $file = "$directory/$options{file_name}"; + next unless -f $file && -r $file; + $main_file = $file; + last; + } + } + + croak 'No config file found, aborting' unless $main_file; + $file_config->file($main_file); + + # process inclusions + my $need_rescan; + foreach my $include_file (split(/\s+/, $file_config->get('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 { + $file_config->file($include_file); + $need_rescan = 1; + } + } + + $file_config->file($main_file) if $need_rescan; + + # merge command line configuration + if ($command_config) { + my %command_vars = $command_config->varlist('.*'); + while (my ($key, $value) = each %command_vars) { + $file_config->set($key, $value); + } + } + + my $self = bless { + _appconfig => $file_config + }, $class; + + return $self; +} + +=head2 get_section($id) + +Simple wrapper around $config->varlist(), throwing a warning if section I<$id> doesn't exists. + +=cut + +sub get_section { + my ($self, $id) = @_; + croak "Not a class method" unless ref $self; + + my %values = $self->{_appconfig}->varlist('^' . $id . '_', 1); + + carp "No such section $id" unless %values; + + foreach my $value (values %values) { + $value = _yamlize($value); + } + + return %values; +} + +sub get { + my ($self, $variable) = @_; + croak "Not a class method" unless ref $self; + + return _yamlize($self->{_appconfig}->get($variable)); +} + +sub _yamlize { + my ($value) = @_; + + if ($value =~ /^--- #YAML:1.0/) { + eval { + $value = Load($value . "\n"); + }; + $value = undef if $@; + } + + return $value; +} + +=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..8ff435b --- /dev/null +++ b/lib/Youri/Media.pm @@ -0,0 +1,311 @@ +# $Id: Media.pm 868 2006-04-11 20:35:09Z guillomovitch $ +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_inputs $input_ids + +list of ids of input 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_inputs => undef, # list of inputs 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_inputs)) { + 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_inputs => $options{skip_inputs}, + }, $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_inputs() + +Returns the list of id of input which are to be skipped for this media. + +=cut + +sub skip_inputs { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return keys %{$self->{_skip_inputs}}; +} + +=head2 skip_input($input_id) + +Tells wether input with given id is to be skipped for this media. + +=cut + +sub skip_input { + my ($self, $input) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_skip_inputs}->{all} || + $self->{_skip_inputs}->{$input}; +} + +=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..ca26860 --- /dev/null +++ b/lib/Youri/Media/URPM.pm @@ -0,0 +1,273 @@ +# $Id: URPM.pm 903 2006-04-21 21:51:48Z guillomovitch $ +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..566d32b --- /dev/null +++ b/lib/Youri/Package.pm @@ -0,0 +1,276 @@ +# $Id: Package.pm 868 2006-04-11 20:35:09Z guillomovitch $ +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_versions($version1, $version2) + +Compares $version1 and $version2, and returns a numeric value: + +=over + +=item > 0 if $version1 > $version2 + +=item 0 if $version1 = $version2 + +=item < 0 if $version1 < $version2 + +=back + +=head2 compare_ranges($range1, $range2) + +Compares $range1 and $range2, and returns a true value if they are compatible. + +=head1 INSTANCE METHODS + +=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_arch() + +Returns the architecture of this package. + +=head2 get_revision_name() + +Returns the revision name of this package (name-version-release). + +=head2 get_full_name() + +Returns the full name of this package (name-version-release.arch). + +=head2 get_file_name() + +Returns the file name of this package (name-version-release.arch.extension). + +=head2 get_file() + +Returns the file containing this package. + +=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 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> + +Textual description of the change, as as array reference of individual changes +(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 release ordering with other package. + +=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 + +1; diff --git a/lib/Youri/Package/RPM.pm b/lib/Youri/Package/RPM.pm new file mode 100644 index 0000000..cdb1680 --- /dev/null +++ b/lib/Youri/Package/RPM.pm @@ -0,0 +1,33 @@ +# $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'; + +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'; +} + +1; diff --git a/lib/Youri/Package/RPM4.pm b/lib/Youri/Package/RPM4.pm new file mode 100644 index 0000000..5437a3d --- /dev/null +++ b/lib/Youri/Package/RPM4.pm @@ -0,0 +1,429 @@ +# $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::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 RPM4; +use RPM4::Header; +use RPM4::Sign; +use File::Spec; +use Scalar::Util qw/refaddr/; +use base 'Youri::Package::RPM'; +use overload + '""' => '_to_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('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 compare_ranges { + 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_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return join('-', ($self->get_name, $self->get_version, $self->get_release)); +} + +sub get_full_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->queryformat('%{NAME}-%{VERSION}-%{RELEASE}.%|SOURCERPM?{%{ARCH}}:{src}|'); +} + +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 get_file { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_file}; +} + +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], + [ + map { s/^.\s+//; $_ } + split(/\n/, $text[$i]) + ] + ]; + } + + return @changes; +} + +sub get_last_change { + my ($self) = @_; + + return [ + ($self->{_header}->tag('changelogname'))[0], + ($self->{_header}->tag('changelogtime'))[0], + [ + map { s/^.\s+//; $_ } + split(/\n/, ($self->{_header}->tag('changelogtext'))[0]) + ] + ]; +} + +sub _to_string { + return $_[0]->{_header}->fullname(); +} + +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 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/URPM.pm b/lib/Youri/Package/URPM.pm new file mode 100644 index 0000000..a01d52b --- /dev/null +++ b/lib/Youri/Package/URPM.pm @@ -0,0 +1,398 @@ +# $Id: URPM.pm 955 2006-07-08 22:38:35Z nanardon $ +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 + '""' => '_to_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 compare_ranges { + 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_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return join('-', ($self->{_header}->fullname())[0 .. 2]); +} + +sub get_full_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->fullname(); +} + +sub get_file_name { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_header}->filename(); +} + +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 get_file { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_file}; +} + +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], + [ + map { s/^.\s+//; $_ } + split(/\n/, $text[$i]) + ] + ]; + } + + return @changes; +} + +sub get_last_change { + my ($self) = @_; + + return [ + ($self->{_header}->changelog_name())[0], + ($self->{_header}->changelog_time())[0], + [ + map { s/^.\s+//; $_ } + split(/\n/, ($self->{_header}->changelog_text())[0]) + ] + ]; +} + +sub _to_string { + return $_[0]->{_header}->fullname(); +} + +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 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 $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..54b3beb --- /dev/null +++ b/lib/Youri/Repository.pm @@ -0,0 +1,384 @@ +# $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 get_package_class() + +Return package class for this repository. + +=head2 get_package_charset() + +Return package charset for this repository. + +=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_older_revisions($package, $target, $define) + +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, $define) = @_; + 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, + $define, + sub { return $package->compare($_[0]) > 0 } + ); +} + +=head2 get_last_older_revision($package, $target, $define) + +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, $define) = @_; + 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, $define))[0]; +} + +=head2 get_newer_revisions($package, $target, $define) + +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, $define) = @_; + 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, + $define, + sub { return $_[0]->compare($package) > 0 } + ); +} + + +=head2 get_revisions($package, $target, $define, $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, $define, $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, $define), + $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, $define) + +Get all packages obsoleted by given one, as a list of L<Youri::Package> +objects. + +=cut + +sub get_obsoleted_packages { + my ($self, $package, $target, $define) = @_; + 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]); + push(@packages, + map { $self->get_package_class()->new(file => $_) } + $self->get_files( + $self->{_install_root}, + $self->get_install_path($package, $target, $define), + $pattern + ) + ); + } + + return @packages; +} + +=head2 get_replaced_packages($package, $target, $define) + +Get all packages replaced by given one, as a list of L<Youri::Package> +objects. + +=cut + +sub get_replaced_packages { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + print "Looking for packages replaced by $package for $target\n" + if $self->{_verbose} > 0; + + return + $self->get_older_revisions($package, $target, $define), + $self->get_obsoleted_packages($package, $target, $define); +} + +=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; + print "Looking for files matching $pattern in $root/$path\n" + if $self->{_verbose} > 1; + + my @files = + grep { -f } + glob "$root/$path/*"; + + @files = + grep { basename($_) =~ /^$pattern$/ } + @files + if $pattern; + + 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_install_dir($package, $target, $define) + +Returns install destination directory for given L<Youri::Package> object +and given target. + +=cut + +sub get_install_dir { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_install_root} . + '/' . + $self->get_install_path($package, $target, $define); +} + +=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, $define) + +Returns archiving destination directory for given L<Youri::Package> object +and given target. + +=cut + +sub get_archive_dir { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_archive_root} . + '/' . + $self->get_archive_path($package, $target, $define); +} + +=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, $define) + +Returns versioning destination directory for given L<Youri::Package> +object and given target. + +=cut + +sub get_version_dir { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return + $self->{_version_root} . + '/' . + $self->get_version_path($package, $target, $define); +} + +=head2 get_install_file($package, $target, $define) + +Returns install destination file for given L<Youri::Package> object and +given target. + +=cut + +sub get_install_file { + my ($self, $package, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return + $self->get_install_dir($package, $target, $define) . + '/' . + $package->get_file_name(); +} + +=head2 get_install_path($package, $target, $define) + +Returns installation destination path (relative to repository root) for given +L<Youri::Package> object and given target. + +=head2 get_archive_path($package, $target, $define) + +Returns archiving destination path (relative to repository root) for given +L<Youri::Package> object and given target. + +=head2 get_version_path($package, $target, $define) + +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/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/Upload/Action.pm b/lib/Youri/Upload/Action.pm new file mode 100644 index 0000000..e7908c4 --- /dev/null +++ b/lib/Youri/Upload/Action.pm @@ -0,0 +1,94 @@ +# $Id: Base.pm 631 2006-01-26 22:22:23Z guillomovitch $ +package Youri::Upload::Action; + +=head1 NAME + +Youri::Upload::Action - Abstract action plugin + +=head1 DESCRIPTION + +This abstract class defines action plugin interface. + +=cut + +use warnings; +use strict; +use Carp; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Upload::Action 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 plugin identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=head2 run($package, $repository, $target, $define) + +Execute action on given L<Youri::Package> 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/Upload/Action/Archive.pm b/lib/Youri/Upload/Action/Archive.pm new file mode 100644 index 0000000..7bf397a --- /dev/null +++ b/lib/Youri/Upload/Action/Archive.pm @@ -0,0 +1,60 @@ +# $Id: Archive.pm 867 2006-04-11 20:34:56Z guillomovitch $ +package Youri::Upload::Action::Archive; + +=head1 NAME + +Youri::Upload::Action::Archive - Old revisions archiving + +=head1 DESCRIPTION + +This action plugin ensures archiving of old package revisions. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + perms => 644, + @_ + ); + + $self->{_perms} = $options{perms}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + foreach my $replaced_package ( + $repository->get_replaced_packages($package, $target, $define) + ) { + my $file = $replaced_package->get_file(); + my $dest = $repository->get_archive_dir($package, $target, $define); + + print "archiving file $file to $dest\n" if $self->{_verbose}; + + unless ($self->{_test}) { + # create destination dir if needed + system("install -d -m " . ($self->{_perms} + 111) . " $dest") + unless -d $dest; + + # install file to new location + system("install -m $self->{_perms} $file $dest"); + } + } +} + +=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/Upload/Action/Bugzilla.pm b/lib/Youri/Upload/Action/Bugzilla.pm new file mode 100644 index 0000000..0f43e09 --- /dev/null +++ b/lib/Youri/Upload/Action/Bugzilla.pm @@ -0,0 +1,81 @@ +# $Id: Bugzilla.pm 867 2006-04-11 20:34:56Z guillomovitch $ +package Youri::Upload::Action::Bugzilla; + +=head1 NAME + +Youri::Upload::Action::Bugzilla - Bugzilla synchronisation + +=head1 DESCRIPTION + +This action plugin ensures synchronisation with Bugzilla. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Bugzilla; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + host => '', + base => '', + user => '', + pass => '', + contact => '', + @_ + ); + + $self->{_bugzilla} = Youri::Bugzilla->new( + $options{host}, + $options{base}, + $options{user}, + $options{pass} + ); + $self->{_contact} = $options{contact}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return unless $package->is_source(); + + my $name = $package->get_name(); + my $version = $package->get_version(); + my $summary = $package->get_summary(); + my $packager = $package->get_packager(); + $packager =~ s/.*<(.*)>/$1/; + + if ($self->{_bugzilla}->has_package($name)) { + my %versions = + map { $_ => 1 } + $self->{_bugzilla}->get_versions($name); + unless ($versions{$version}) { + print "adding version $version to bugzilla\n" if $self->{_verbose}; + $self->{_bugzilla}->add_version($name, $version) + unless $self->{_test}; + } + } else { + print "adding package $name to bugzilla\n" if $self->{_verbose}; + $self->{_bugzilla}->add_package( + $name, + $summary, + $version, + $packager, + $self->{_contact} + ) 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/Upload/Action/CVS.pm b/lib/Youri/Upload/Action/CVS.pm new file mode 100644 index 0000000..6957e78 --- /dev/null +++ b/lib/Youri/Upload/Action/CVS.pm @@ -0,0 +1,135 @@ +# $Id: CVS.pm 867 2006-04-11 20:34:56Z guillomovitch $ +package Youri::Upload::Action::CVS; + +=head1 NAME + +Youri::Upload::Action::CVS - CVS versionning + +=head1 DESCRIPTION + +This action plugin ensures CVS versionning of package sources. + +=cut + +use warnings; +use strict; +use Carp; +use Cwd; +use File::Temp qw/tempdir/; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + exclude => '\.(tar(\.(gz|bz2))?|zip)$', + perms => 644, + @_ + ); + + $self->{_exclude} = $options{exclude}; + $self->{_perms} = $options{perms}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return unless $package->is_source(); + + my $name = $package->get_name(); + my $version = $package->get_version(); + my $release = $package->get_release(); + + my $root = $repository->get_version_root(); + my $path = $repository->get_version_path($package, $target, $define); + + # remember original directory + my $original_dir = cwd(); + + # get a safe temporary directory + my $dir = tempdir( CLEANUP => 1 ); + chdir $dir; + + # first checkout base directory only + system("cvs -Q -d $root co -l $path"); + + # try to checkout package directory + my $dest = $path . '/' . $name; + system("cvs -Q -d $root co $dest"); + + # create directory if previous import failed + unless (-d $dest) { + print "adding directory $dest\n" if $self->{_verbose}; + system("install -d -m " . ($self->{_perms} + 111) . " $dest"); + system("cvs -Q -d $root add $dest"); + } + + chdir $dest; + + # remove all files + unlink grep { -f } glob '*'; + + # extract all rpm files locally + $package->extract(); + + # remove excluded files + if ($self->{_exclude}) { + unlink grep { -f && /$self->{_exclude}/ } glob '*'; + } + + # uncompress all compressed files + system("bunzip2 *.bz2 2>/dev/null"); + system("gunzip *.gz 2>/dev/null"); + + my (@to_remove, @to_add, @to_add_binary); + foreach my $line (`cvs -nq update`) { + if ($line =~ /^\? (\S+)/) { + if (-B $1) { + push(@to_add_binary, $1); + } else { + push(@to_add, $1); + } + } + if ($line =~ /^U (\S+)/) { + push(@to_remove, $1); + } + } + if (@to_remove) { + my $to_remove = join(' ', @to_remove); + print "removing file(s) $to_remove\n" if $self->{_verbose}; + system("cvs -Q remove $to_remove"); + } + if (@to_add) { + my $to_add = join(' ', @to_add); + print "adding text file(s) $to_add\n" if $self->{_verbose}; + system("cvs -Q add $to_add"); + } + if (@to_add_binary) { + my $to_add_binary = join(' ', @to_add_binary); + print "adding binary file(s) $to_add_binary\n" if $self->{_verbose}; + system("cvs -Q add -kb $to_add_binary"); + } + + print "committing current directory\n" if $self->{_verbose}; + system("cvs -Q commit -m $version-$release") unless $self->{_test}; + + # tag new release + my $tag = "r$version-$release"; + $tag =~ s/\./_/g; + print "tagging current directory as $tag\n" if $self->{_verbose}; + system("cvs -Q tag $tag") unless $self->{_test}; + + # get back to original directory + chdir $original_dir; + +} + +=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/Upload/Action/Clean.pm b/lib/Youri/Upload/Action/Clean.pm new file mode 100644 index 0000000..8564756 --- /dev/null +++ b/lib/Youri/Upload/Action/Clean.pm @@ -0,0 +1,40 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/Backup.pm 867 2006-01-29T20:47:27.830648Z guillaume $ +package Youri::Upload::Action::Clean; + +=head1 NAME + +Youri::Upload::Action::Clean - Old revisions cleanup + +=head1 DESCRIPTION + +This action plugin ensures cleanup of old package revisions. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Action/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + foreach my $replaced_package ( + $repository->get_replaced_packages($package, $target, $define) + ) { + my $file = $replaced_package->get_file(); + print "deleting file $file\n" if $self->{_verbose}; + unlink $file 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/Upload/Action/Install.pm b/lib/Youri/Upload/Action/Install.pm new file mode 100644 index 0000000..56fc09c --- /dev/null +++ b/lib/Youri/Upload/Action/Install.pm @@ -0,0 +1,58 @@ +# $Id: Install.pm 867 2006-04-11 20:34:56Z guillomovitch $ +package Youri::Upload::Action::Install; + +=head1 NAME + +Youri::Upload::Action::Install - Package installation + +=head1 DESCRIPTION + +This action plugin ensures installation of new package revisions. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + perms => 644, + @_ + ); + + $self->{_perms} = $options{perms}; + + return $self; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my $file = $package->get_file(); + my $dest = $repository->get_install_dir($package, $target, $define); + + print "installing file $file to $dest\n" if $self->{_verbose}; + + unless ($self->{_test}) { + # create destination dir if needed + system("install -d -m " . ($self->{_perms} + 111) . " $dest") + unless -d $dest; + + # install file to new location + system("install -m $self->{_perms} $file $dest"); + } +} + +=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/Upload/Action/Link.pm b/lib/Youri/Upload/Action/Link.pm new file mode 100644 index 0000000..eaadec1 --- /dev/null +++ b/lib/Youri/Upload/Action/Link.pm @@ -0,0 +1,63 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/Sign.pm 1543 2006-03-21T20:22:54.334939Z guillaume $ +package Youri::Upload::Action::Link; + +=head1 NAME + +Youri::Upload::Action::Link - Noarch packages linking + +=head1 DESCRIPTION + +This action plugin ensures linking of noarch packages between arch-specific +directories. + +=cut + +use warnings; +use strict; +use Carp; +use File::Spec; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + symbolic => 0, # use symbolic linking + @_ + ); + + $self->{_symbolic} = $options{symbolic}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + # only needed for noarch packages + return unless $package->get_arch() eq 'noarch'; + + my $dest_dir = $repository->get_install_dir($package, $target, $define); + my (undef, $parent_dir, $relative_dir) = File::Spec->splitpath($dest_dir); + my $file = $package->get_file_name(); + + foreach my $other_dir (grep { -d } <$parent_dir/*>) { + next if $other_dir eq $dest_dir; + chdir $other_dir; + my $source_file = "../$relative_dir/$file"; + if ($self->{_symbolic}) { + symlink $source_file, $file unless $self->{_test}; + } else { + link $source_file, $file unless $self->{_test}; + } + chdir '..'; + } +} + +=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/Upload/Action/Mail.pm b/lib/Youri/Upload/Action/Mail.pm new file mode 100644 index 0000000..c895ec7 --- /dev/null +++ b/lib/Youri/Upload/Action/Mail.pm @@ -0,0 +1,115 @@ +# $Id: Mail.pm 901 2006-04-21 21:35:10Z guillomovitch $ +package Youri::Upload::Action::Mail; + +=head1 NAME + +Youri::Upload::Action::Mail - Mail notification + +=head1 DESCRIPTION + +This action plugin ensures mail notification of new package revisions. + +=cut + +use warnings; +use strict; +use MIME::Entity; +use Encode qw/from_to/; +use Carp; +use Youri::Package; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + mta => '/usr/sbin/sendmail', + to => '', + from => '', + cc => '', + prefix => '', + encoding => 'quoted-printable', + charset => 'iso-8859-1', + @_ + ); + + croak "undefined mail MTA" unless $options{mta}; + croak "invalid mail MTA $options{mta}" unless -x $options{mta}; + croak "undefined to" unless $options{to}; + if ($options{cc}) { + croak "cc should be an hashref" unless ref $options{cc} eq 'HASH'; + } + croak "invalid charset $options{charset}" + unless Encode::resolve_alias($options{charset}); + + $self->{_mta} = $options{mta}; + $self->{_to} = $options{to}; + $self->{_from} = $options{from}; + $self->{_cc} = $options{cc}; + $self->{_prefix} = $options{prefix}; + $self->{_encoding} = $options{encoding}; + $self->{_charset} = $options{charset}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return unless $package->is_source(); + + my $from = $package->get_packager(); + + # force from adress if defined + $from =~ s/<.*>/<$self->{_from}>/ if $self->{_from}; + + my $subject = + ($self->{_prefix} ? '[' . $self->{_prefix} . '] ' : '' ) . + $package->get_revision_name(); + my $information = $package->get_information(); + my $last_change = $package->get_last_change(); + my $content = + $information . "\n" . + $last_change->[Youri::Package::CHANGE_AUTHOR] . ":\n" . + join( + '', map { "- $_\n" } @{$last_change->[Youri::Package::CHANGE_TEXT]} + ); + + # ensure proper codeset conversion + # for informations coming from package + my $charset = $repository->get_package_charset(); + from_to($content, $charset, $self->{_charset}); + from_to($subject, $charset, $self->{_charset}); + + my $mail = MIME::Entity->build( + Type => 'text/plain', + Charset => $self->{_charset}, + Encoding => $self->{_encoding}, + From => $from, + To => $self->{_to}, + Subject => $subject, + Data => $content, + ); + + if ($self->{_cc}) { + my $cc = $self->{_cc}->{$package->get_name()}; + $mail->head()->add('cc', $cc) if $cc; + } + + 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/Upload/Action/RSS.pm b/lib/Youri/Upload/Action/RSS.pm new file mode 100644 index 0000000..2624199 --- /dev/null +++ b/lib/Youri/Upload/Action/RSS.pm @@ -0,0 +1,102 @@ +# $Id: RSS.pm 901 2006-04-21 21:35:10Z guillomovitch $ +package Youri::Upload::Action::RSS; + +=head1 NAME + +Youri::Upload::Action::RSS - RSS notification + +=head1 DESCRIPTION + +This action plugin ensures RSS notification of new package revisions. + +=cut + +use warnings; +use strict; +use XML::RSS; +use Encode qw/from_to/; +use Carp; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + file => '', + title => '', + link => '', + description => '', + charset => 'iso-8859-1', + max_items => 10, + @_ + ); + + croak "undefined rss file" unless $options{file}; + croak "invalid charset $options{charset}" + unless Encode::resolve_alias($options{charset}); + + $self->{_file} = $options{file}; + $self->{_title} = $options{title}; + $self->{_link} = $options{link}; + $self->{_description} = $options{description}; + $self->{_charset} = $options{charset}; + $self->{_max_items} = $options{max_items}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + return unless $package->is_source(); + + my $subject = $package->get_revision_name(); + my $content = $package->get_information(); + + $content =~ s/$/<br\/>/mg; + + # ensure proper codeset conversion + # for informations coming from package + my $charset = $repository->get_package_charset(); + from_to($content, $charset, $self->{_charset}); + from_to($subject, $charset, $self->{_charset}); + + my $rss = XML::RSS->new( + encoding => $self->{_charset}, + encode_output => 1 + ); + + my $file = $self->{_file}; + if (-e $file) { + $rss->parsefile($file); + splice(@{$rss->{items}}, $self->{_max_items}) + if @{$rss->{items}} >= $self->{_max_items}; + } else { + $rss->channel( + title => $self->{_title}, + link => $self->{_link}, + description => $self->{_description}, + language => 'en' + ); + } + + $rss->add_item( + title => $subject, + description => $content, + mode => 'insert' + ); + + if ($self->{_test}) { + print $rss->as_string(); + } else { + $rss->save($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/Upload/Action/Sign.pm b/lib/Youri/Upload/Action/Sign.pm new file mode 100644 index 0000000..468e3cc --- /dev/null +++ b/lib/Youri/Upload/Action/Sign.pm @@ -0,0 +1,56 @@ +# $Id: Sign.pm 867 2006-04-11 20:34:56Z guillomovitch $ +package Youri::Upload::Action::Sign; + +=head1 NAME + +Youri::Upload::Action::Sign - GPG signature + +=head1 DESCRIPTION + +This action plugin ensures GPG signature of packages. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Action/; + +sub _init { + my $self = shift; + my %options = ( + name => '', + path => $ENV{HOME} . '/.gnupg', + passphrase => '', + @_ + ); + + croak "undefined name" unless $options{name}; + croak "undefined path" unless $options{path}; + croak "invalid path $options{path}" unless -d $options{path}; + + $self->{_name} = $options{name}; + $self->{_path} = $options{path}; + $self->{_passphrase} = $options{passphrase}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + $package->sign( + $self->{_name}, + $self->{_path}, + $self->{_passphrase} + ) 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/Upload/Check.pm b/lib/Youri/Upload/Check.pm new file mode 100644 index 0000000..312c4a6 --- /dev/null +++ b/lib/Youri/Upload/Check.pm @@ -0,0 +1,107 @@ +# $Id: Base.pm 631 2006-01-26 22:22:23Z guillomovitch $ +package Youri::Upload::Check; + +=head1 NAME + +Youri::Upload::Check - Abstract check plugin + +=head1 DESCRIPTION + +This abstract class defines check plugin interface. + +=cut + +use warnings; +use strict; +use Carp; + +=head1 CLASS METHODS + +=head2 new(%args) + +Creates and returns a new Youri::Upload::Check 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 plugin identity. + +=cut + +sub get_id { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_id}; +} + +=head2 run($package, $repository, $target, $define) + +Check given L<Youri::Package> object, and returns success as a boolean. + +=head2 get_error() + +Returns exact error message if check failed. + +=cut + +sub get_error { + my ($self) = @_; + croak "Not a class method" unless ref $self; + + return $self->{_error}; +} + +=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/Upload/Check/History.pm b/lib/Youri/Upload/Check/History.pm new file mode 100644 index 0000000..81d65bd --- /dev/null +++ b/lib/Youri/Upload/Check/History.pm @@ -0,0 +1,56 @@ +# $Id: History.pm 965 2006-07-27 09:38:18Z guillomovitch $ +package Youri::Upload::Check::History; + +=head1 NAME + +Youri::Upload::Check::History - Non-linear history check + +=head1 DESCRIPTION + +This check plugin rejects packages whose history does not include last +available revision one. + +=cut + +use warnings; +use strict; +use Carp; +use Youri::Package; +use base qw/Youri::Upload::Check/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my $last_revision = + $repository->get_last_older_revision($package, $target, $define); + + if ($last_revision) { + # skip the test if last revision has been produced from another source package, as it occurs during package split/merges + return 1 + if $last_revision->get_canonical_name() ne $package->get_canonical_name(); + + my ($last_revision_number) = $last_revision->get_last_change()->[Youri::Package::CHANGE_AUTHOR] =~ /(\S+)\s*$/; + my %entries = + map { $_ => 1 } + map { /(\S+)\s*$/ } + map { $_->[Youri::Package::CHANGE_AUTHOR] } + $package->get_changes(); + unless ($entries{$last_revision_number}) { + $self->{_error} = "Last changelog entry $last_revision_number from last revision " . $last_revision->get_full_name() . " missing from current changelog"; + return 0; + } + } + + return 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/Upload/Check/Precedence.pm b/lib/Youri/Upload/Check/Precedence.pm new file mode 100644 index 0000000..b03c2ad --- /dev/null +++ b/lib/Youri/Upload/Check/Precedence.pm @@ -0,0 +1,54 @@ +# $Id: Precedence.pm 873 2006-04-15 17:04:27Z guillomovitch $ +package Youri::Upload::Check::Precedence; + +=head1 NAME + +Youri::Upload::Check::Precedence - Release check against another check + +=head1 DESCRIPTION + +This check plugin rejects packages whose an older revision already exists for +another upload target. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Check/; + +sub _init { + my $self = shift; + my %options = ( + _target => undef, # mandatory targets + @_ + ); + + die "undefined target" unless $options{target}; + + $self->{_target} = $options{target}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @older_revisions = + $repository->get_older_revisions($package, $self->{_target}, $define); + if (@older_revisions) { + $self->{_error} = "Older revisions still exists for $self->{_target}: " . join(', ', @older_revisions); + return 0; + } + + return 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/Upload/Check/Recency.pm b/lib/Youri/Upload/Check/Recency.pm new file mode 100644 index 0000000..d6fc920 --- /dev/null +++ b/lib/Youri/Upload/Check/Recency.pm @@ -0,0 +1,48 @@ +# $Id: Recency.pm 873 2006-04-15 17:04:27Z guillomovitch $ +package Youri::Upload::Check::Recency; + +=head1 NAME + +Youri::Upload::Check::Recency - Release check against current target + +=head1 DESCRIPTION + +This check plugin rejects packages whose a current or newer revision already +exists for current upload target. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Check/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my $file = $repository->get_install_file($package, $target, $define); + if (-f $file) { + $self->{_error} = "Current revision already exists for $target"; + return 0; + } + + my @newer_revisions = + $repository->get_newer_revisions($package, $target, $define); + if (@newer_revisions) { + $self->{_error} = "Newer revisions already exists for $target: " . join(', ', @newer_revisions); + return 0; + } + + return 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/Upload/Check/Tag.pm b/lib/Youri/Upload/Check/Tag.pm new file mode 100644 index 0000000..ef89ff6 --- /dev/null +++ b/lib/Youri/Upload/Check/Tag.pm @@ -0,0 +1,56 @@ +# $Id: Tag.pm 867 2006-04-11 20:34:56Z guillomovitch $ +package Youri::Upload::Check::Tag; + +=head1 NAME + +Youri::Upload::Check::Tag - Incorrect tag values check + +=head1 DESCRIPTION + +This check plugin rejects packages with incorrect tag values, based on regular +expressions. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Check/; + +sub _init { + my $self = shift; + my %options = ( + tags => undef, # expected tag values + @_ + ); + + croak "no tags to check" unless $options{tags}; + croak "tag should be an hashref" unless ref $options{tags} eq 'HASH'; + + $self->{_tags} = $options{tags}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + foreach my $tag (keys %{$self->{_tags}}) { + my $value = $package->get_tag($tag); + if ($value !~ /$self->{_tags}->{$tag}/) { + $self->{_error} = "invalid value $value for tag $tag"; + return 0; + } + } + + return 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/Upload/Check/Type.pm b/lib/Youri/Upload/Check/Type.pm new file mode 100644 index 0000000..e03fa80 --- /dev/null +++ b/lib/Youri/Upload/Check/Type.pm @@ -0,0 +1,53 @@ +# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Check/Tag.pm 1642 2006-03-29T06:49:43.840267Z guillaume $ +package Youri::Upload::Check::Type; + +=head1 NAME + +Youri::Upload::Check::Type - Type check + +=head1 DESCRIPTION + +This check plugin rejects packages with incorrect type. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Upload::Check/; + +sub _init { + my $self = shift; + my %options = ( + type => undef, # expected type + @_ + ); + + croak "no type to check" unless $options{type}; + croak "invalid type value" unless $options{type} =~ /^(?:source|binary)$/; + + $self->{_type} = $options{type}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my $type = $package->get_type(); + if ($type ne $self->{_type}) { + $self->{_error} = "invalid type $type"; + return 0; + } + + return 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/Utils.pm b/lib/Youri/Utils.pm new file mode 100644 index 0000000..76359ed --- /dev/null +++ b/lib/Youri/Utils.pm @@ -0,0 +1,90 @@ +# $Id: Utils.pm 697 2006-02-26 16:44:54Z guillomovitch $ +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 + add2hash + add2hash_ +); + +=head2 create_instance(class => I<$class>, I<%options>) + +Create an instance of a class at runtime. +I<$class> is the class name. +I<%options> are passed to the class constructor. +Returns the class instance. + +=cut + +sub create_instance { + my ($expected_class, %options) = @_; + + die 'No expected class given' unless $expected_class; + die "No class given, expected derivated class from '$expected_class'" unless $options{class}; + + # extract class from options + my $class = $options{class}; + delete $options{class}; + + # ensure loaded + load($class); + + # check interface + die "$class is not a $expected_class" unless $class->isa($expected_class); + + # instantiate + no strict 'refs'; + return $class->new(%options); +} + +sub load { + 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; |