diff options
Diffstat (limited to 'lib/Youri/Submit/Test')
-rw-r--r-- | lib/Youri/Submit/Test/ACL.pm | 71 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/History.pm | 61 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Host.pm | 63 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Precedence.pm | 58 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Queue_recency.pm | 40 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Recency.pm | 46 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Rpmlint.pm | 89 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/SVN.pm | 79 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Section.pm | 58 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Source.pm | 45 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Tag.pm | 61 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Type.pm | 54 | ||||
-rw-r--r-- | lib/Youri/Submit/Test/Version.pm | 100 |
13 files changed, 825 insertions, 0 deletions
diff --git a/lib/Youri/Submit/Test/ACL.pm b/lib/Youri/Submit/Test/ACL.pm new file mode 100644 index 0000000..34bf48a --- /dev/null +++ b/lib/Youri/Submit/Test/ACL.pm @@ -0,0 +1,71 @@ +# $Id$ +package Youri::Submit::Check::ACL; + +=head1 NAME + +Youri::Submit::Check::Tag - Incorrect tag values check + +=head1 DESCRIPTION + +This check plugin rejects packages with incorrect tag values, based on regular +expressions. + +=cut + +use strict; +use Carp; +use base qw/Youri::Submit::Check/; +my $acl; + +sub _init { + my $self = shift; + my %options = ( + acl_file => '', + @_ + ); + $acl = get_acl($options{acl_file}); +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + my $file = $package->get_full_name(); + my $arch = $package->get_arch(); + my $srpm = $package->get_canonical_name; + my $section = $repository->_get_section($package, $target, $define); + my $user = $define->{user}; + foreach my $t (keys %$acl) { + next if $target !~ /$t/; + foreach my $acl (@{$acl->{$t}}) { + my ($a, $media, $r, $users) = @$acl; + next if $arch !~ $a || $srpm !~ $r || $section !~ $media; + if ($user =~ /$users/) { + return + } else { + return "$user is not authorized to upload packages belonging to $srpm in section $section (authorized persons: " . join(', ', split '\|', $users) . ")"; + } + } + } + return +} + +sub get_acl { + my ($file) = @_; + my %acl; + open my $f, $file; + while (<$f>) { + my ($dis, $arch, $media, $regexp, $users) = split ' '; + push @{$acl{$dis}}, [ $arch , $media, $regexp, $users ] + } + \%acl +} + +=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/Submit/Test/History.pm b/lib/Youri/Submit/Test/History.pm new file mode 100644 index 0000000..326f2f1 --- /dev/null +++ b/lib/Youri/Submit/Test/History.pm @@ -0,0 +1,61 @@ +# $Id$ +package Youri::Submit::Check::History; + +=head1 NAME + +Youri::Submit::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::Submit::Check/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @errors; + + 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 + 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}) { + push( + @errors, + "Last changelog entry $last_revision_number from last revision " . $last_revision->get_full_name() . " missing from current changelog" + ); + } + } + + return @errors; +} + +=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/Submit/Test/Host.pm b/lib/Youri/Submit/Test/Host.pm new file mode 100644 index 0000000..b2b392a --- /dev/null +++ b/lib/Youri/Submit/Test/Host.pm @@ -0,0 +1,63 @@ +# $Id$ +package Youri::Submit::Check::Host; + +=head1 NAME + +Youri::Submit::Check::Tag - Incorrect tag values check + +=head1 DESCRIPTION + +This check plugin rejects packages with incorrect tag values, based on regular +expressions. + +=cut + +use strict; +use Carp; +use base qw/Youri::Submit::Check/; +my $host; + +sub _init { + my $self = shift; + my %options = ( + host_file => '', + @_ + ); + $host = get_host($options{host_file}) +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + my $file = $package->get_file; + my $arch = $package->get_arch; + my $buildhost = $package->as_formated_string('%{buildhost}'); + foreach my $h (keys %$host) { + next if $buildhost !~ $h; + if ($arch =~ $host->{$h}) { + return + } + } + "Packages build on host $buildhost are not authorized"; +} + +sub get_host { + my ($file) = @_; + my %host; + open my $f, $file; + while (<$f>) { + my ($host, $arch) = split ' '; + $host{$host} = $arch + } + \%host +} + +=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/Submit/Test/Precedence.pm b/lib/Youri/Submit/Test/Precedence.pm new file mode 100644 index 0000000..c73446b --- /dev/null +++ b/lib/Youri/Submit/Test/Precedence.pm @@ -0,0 +1,58 @@ +# $Id$ +package Youri::Submit::Check::Precedence; + +=head1 NAME + +Youri::Submit::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::Submit::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 @errors; + + my @older_revisions = + $repository->get_older_revisions($package, $self->{_target}, $define); + if (@older_revisions) { + push( + @errors, + "Older revisions still exists for $self->{_target}: " . join(', ', @older_revisions) + ); + } + + return @errors; +} + +=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/Submit/Test/Queue_recency.pm b/lib/Youri/Submit/Test/Queue_recency.pm new file mode 100644 index 0000000..42c4f42 --- /dev/null +++ b/lib/Youri/Submit/Test/Queue_recency.pm @@ -0,0 +1,40 @@ +# $Id$ +package Youri::Submit::Check::Queue_recency; + +=head1 NAME + +Youri::Submit::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::Submit::Check/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @newer_revisions = + $repository->get_upload_newer_revisions($package, $target, $define); + if (@newer_revisions) { + return "Newer revisions already exists for $target in upload queue: " . join(', ', @newer_revisions); + } + return +} + +=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/Submit/Test/Recency.pm b/lib/Youri/Submit/Test/Recency.pm new file mode 100644 index 0000000..f8aa5b7 --- /dev/null +++ b/lib/Youri/Submit/Test/Recency.pm @@ -0,0 +1,46 @@ +# $Id$ +package Youri::Submit::Check::Recency; + +=head1 NAME + +Youri::Submit::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::Submit::Check/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @errors; + + my @revisions = $repository->get_revisions($package, $target, $define, undef, sub { return $_[0]->compare($package) >= 0 }); + if (@revisions) { + push( + @errors, + "Current or newer revision(s) already exists for $target: " . + join(', ', @revisions) + ); + } + + return @errors; +} + +=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/Submit/Test/Rpmlint.pm b/lib/Youri/Submit/Test/Rpmlint.pm new file mode 100644 index 0000000..a38f2ba --- /dev/null +++ b/lib/Youri/Submit/Test/Rpmlint.pm @@ -0,0 +1,89 @@ +# $Id$ +package Youri::Submit::Check::Rpmlint; + +=head1 NAME + +Youri::Submit::Check::Rpmlint - Rpmlint-based check + +=head1 DESCRIPTION + +This check plugin wraps rpmlint, and reject packages triggering results +declared as fatal. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Submit::Check/; + +=head2 new(%args) + +Creates and returns a new Youri::Submit::Check::Rpmlint object. + +Specific parameters: + +=over + +=item results $results + +List of rpmlint result id considered as fatal. + +=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 = ( + results => undef, + path => '/usr/bin/rpmlint', + config => '', + @_ + ); + + croak "no results to check" unless $options{results}; + croak "fatal should be an arrayref" unless ref $options{results} eq 'ARRAY'; + + $self->{_config} = $options{config}; + $self->{_path} = $options{path}; + $self->{_pattern} = '^(?:' . join('|', @{$options{results}}) . ')$'; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @errors; + + my $command = "$self->{_path} -f $self->{_config} " . $package->as_file(); + open(RPMLINT, "$command |") or die "Can't run $command: $!"; + while (my $line = <RPMLINT>) { + my ($id, $value) = $line =~ /^[EW]: \S+ (\S+)(.*)$/; + $id or next; + if ($id =~ /$self->{_pattern}/o) { + push(@errors, "$id$value"); + } + } + + return @errors; +} +=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/Submit/Test/SVN.pm b/lib/Youri/Submit/Test/SVN.pm new file mode 100644 index 0000000..10ab810 --- /dev/null +++ b/lib/Youri/Submit/Test/SVN.pm @@ -0,0 +1,79 @@ +# $Id$ +package Youri::Submit::Check::SVN; + +=head1 NAME + +Youri::Submit::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::Submit::Check/; + +sub _init { + my $self = shift; + my %options = ( + svn => '', + @_ + ); + $self->{_svn} = $options{svn}; +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my $section = $repository->_get_section($package, $target, $define); + if ($section =~ /\/(testing|backport)$/) { + # FIXME, right now ignore packages in SVN for testing and backports + # we need to find a clean way to handle them + return + } + + $package->is_source or return; + my $file = $package->get_file_name; + my $srpm_name = $package->get_canonical_name; + if ($repository->package_in_svn($srpm_name)) { + if ($file !~ /(^|\/|$define->{prefix}_)@\d+:\Q$srpm_name/) { + return "package $srpm_name is in the SVN, the uploaded SRPM must look like @<svn rev>:$srpm_name-<version>-<release>.src.rpm (created with getsrpm-mdk $srpm_name)"; + } else { + print "Package $file is correct\n"; + } + } + return +} + +sub simple_prompt { + my $cred = shift; + my $realm = shift; + my $default_username = shift; + my $may_save = shift; + my $pool = shift; + + print "Enter authentication info for realm: $realm\n"; + print "Username: "; + my $username = <>; + chomp($username); + $cred->username($username); + print "Password: "; + my $password = <>; + chomp($password); + $cred->password($password); +} + +=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/Submit/Test/Section.pm b/lib/Youri/Submit/Test/Section.pm new file mode 100644 index 0000000..4ff1675 --- /dev/null +++ b/lib/Youri/Submit/Test/Section.pm @@ -0,0 +1,58 @@ +# $Id: Precedence.pm 1707 2006-10-16 16:26:42Z warly $ +package Youri::Submit::Check::Section; + +=head1 NAME + +Youri::Submit::Check::Section - Check if package was submitted to the right section + +=head1 DESCRIPTION + +This check plugin rejects packages which were submitted to a section +different than the one where an older version already exists. + +=cut + +use warnings; +use strict; +use Carp; +use base qw/Youri::Submit::Check/; + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + + my @errors; + + my $submitted_main_section = $repository->_get_main_section($package, $target, $define); + + # undefine section, so that Repository::_get_section() of Mandriva_upload.pm + # finds the section from existing packages + my $defined_section = $define->{section}; + undef $define->{section}; + + my $old_main_section = $repository->_get_main_section($package, $target, $define); + my @older_revisions = $repository->get_older_revisions($package, $target, $define); + + # restore defined section + $define->{section} = $defined_section; + + if (@older_revisions && $submitted_main_section ne $old_main_section) { + push( + @errors, + "Section should be $old_main_section, not $submitted_main_section." + ); + } + + + return @errors; +} + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2007, Mandriva + +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/Submit/Test/Source.pm b/lib/Youri/Submit/Test/Source.pm new file mode 100644 index 0000000..ab64e6c --- /dev/null +++ b/lib/Youri/Submit/Test/Source.pm @@ -0,0 +1,45 @@ +# $Id$ +package Youri::Submit::Check::Source; + +=head1 NAME + +Youri::Submit::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::Submit::Check/; + +sub _init { + my $self = shift; + my %options = ( + @_ + ); +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + my $file = $package->as_file(); + if (!$package->is_source()) { + return "Package $file is not a source rpm"; + } + return +} + +=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/Submit/Test/Tag.pm b/lib/Youri/Submit/Test/Tag.pm new file mode 100644 index 0000000..3fadfa3 --- /dev/null +++ b/lib/Youri/Submit/Test/Tag.pm @@ -0,0 +1,61 @@ +# $Id$ +package Youri::Submit::Check::Tag; + +=head1 NAME + +Youri::Submit::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::Submit::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; + + my @errors; + + foreach my $tag (keys %{$self->{_tags}}) { + my $value = $package->get_tag($tag); + if ($value !~ /$self->{_tags}->{$tag}/) { + push( + @errors, + "invalid value $value for tag $tag" + ); + } + } + + return @errors; + +} + +=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/Submit/Test/Type.pm b/lib/Youri/Submit/Test/Type.pm new file mode 100644 index 0000000..2c0be9b --- /dev/null +++ b/lib/Youri/Submit/Test/Type.pm @@ -0,0 +1,54 @@ +# $Id$ +package Youri::Submit::Check::Type; + +=head1 NAME + +Youri::Submit::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::Submit::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 @errors; + + my $type = $package->get_type(); + if ($type ne $self->{_type}) { + push(@errors, "invalid type $type"); + } + + return @errors; +} + +=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/Submit/Test/Version.pm b/lib/Youri/Submit/Test/Version.pm new file mode 100644 index 0000000..289ffe0 --- /dev/null +++ b/lib/Youri/Submit/Test/Version.pm @@ -0,0 +1,100 @@ +# $Id$ +package Youri::Submit::Check::Version; + +=head1 NAME + +Youri::Submit::Check::Version - Check if older version already exist in cooker (used in freeze period) + +=head1 DESCRIPTION + +This check plugin rejects new version of packages if they are not mentioned as authorized +in the configuration file or in a non frozen section. + +=cut + +use warnings; +use strict; +use Carp; +use URPM; +use base qw/Youri::Submit::Check/; + +sub _init { + my $self = shift; + my %options = ( + @_ + ); + + foreach my $target (keys %options) { + $self->{$target} = $options{$target} + } +} + +sub run { + my ($self, $package, $repository, $target, $define) = @_; + croak "Not a class method" unless ref $self; + my $opt = $self->{$target}; + return if $opt->{mode} eq 'normal'; + my $section = $repository->_get_section($package, $target, $define); + my $name = $package->get_canonical_name; + return if $name =~ /$opt->{authorized_packages}/; + my $arch = $repository->get_arch($package, $target, $define); + return if $arch =~ /$opt->{authorized_arches}/; + if ($opt->{mode} eq 'version_freeze') { + return if $section =~ /$opt->{authorized_sections}/; + my $user = $define->{user}; + return if $user =~ /$opt->{authorized_users}/; + my ($package_version) = $package =~ /-([^-]+)-[^-]+\.src$/; + $define->{arch} = 'src'; + my @revisions = $repository->get_revisions($package, $target, $define, undef, + sub { + my ($version) = $_[0] =~ /-([^-]+)-[^-]+\.src$/; + URPM::ranges_overlap("== $version", "< $package_version") + } + ); + $define->{arch} = ''; + if (@revisions) { + return "FREEZE, package @revisions of different versions exist in $target\n"; + } + } + # FIXME: The following code is not working and must be reviewed. + elsif ($opt->{mode} eq 'freeze') { + # XXX: So freeze mode really only check for this exceptions? + if ($section !~ /$opt->{authorized_sections}/) { + return "FREEZE: repository $target section $section is frozen, you can still submit your packages in testing\nTo do so use your.devel --define section=<section> $target <package 1> <package 2> ... <package n>"; + } + } else { + # FIXME: Calls to get_source_package seems invalid nowadays. + # This results on $source having a null content. + my $source = $package->get_source_package; + my ($package_version) = $source =~ /-([^-]+)-[^-]+\.src\.rpm$/; + $define->{arch} = 'src'; + # FIXME: get_revisions now expects the filter as the 5th element, and not the 4th. + my @revisions = $repository->get_revisions($package, $target, $define, + sub { + # FIXME: Calls to get_source_package seems invalid nowadays. + # This results on $source_package having a null content. + my $source_package = $_[0]->get_source_package; + my ($version) = $source_package =~ /-([^-]+)-[^-]+\.src\.rpm$/; + print STDERR "Found version $version\n"; + URPM::ranges_overlap("== $version", "< $package_version") + } + ); + $define->{arch} = ''; + if (@revisions) { + return "FREEZE, package @revisions of different versions exist in $target\n"; + } + } + return +} + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2006, YOURI project +Copyright (C) 2006, Mandriva + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; + |