aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Youri
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Youri')
-rw-r--r--lib/Youri/Repository/Mandriva_upload.pm297
-rw-r--r--lib/Youri/Repository/Mandriva_upload_pre.pm259
-rw-r--r--lib/Youri/Upload/Action/Markrelease.pm55
-rw-r--r--lib/Youri/Upload/Action/Send.pm72
-rw-r--r--lib/Youri/Upload/Check/ACL.pm74
-rw-r--r--lib/Youri/Upload/Check/Host.pm64
-rw-r--r--lib/Youri/Upload/Check/Queue_recency.pm42
-rw-r--r--lib/Youri/Upload/Check/Recency.pm1
-rw-r--r--lib/Youri/Upload/Check/Rpmlint.pm57
-rw-r--r--lib/Youri/Upload/Check/SVN.pm74
-rw-r--r--lib/Youri/Upload/Check/Source.pm47
11 files changed, 1042 insertions, 0 deletions
diff --git a/lib/Youri/Repository/Mandriva_upload.pm b/lib/Youri/Repository/Mandriva_upload.pm
new file mode 100644
index 0000000..0b5ee58
--- /dev/null
+++ b/lib/Youri/Repository/Mandriva_upload.pm
@@ -0,0 +1,297 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/RSS.pm 857 2006-01-29T10:15:43.298856Z guillaume $
+package Youri::Repository::Mandriva_upload;
+
+=head1 NAME
+
+Youri::Repository::PLF - PLF repository implementation
+
+=head1 DESCRIPTION
+
+This module implements PLF repository.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Memoize;
+use File::Find 'find';
+use base qw/Youri::Repository/;
+use MDV::Distribconf::Build;
+use SVN::Client;
+use constant {
+ PACKAGE_CLASS => 'Youri::Package::URPM',
+ PACKAGE_CHARSET => 'utf8'
+};
+
+memoize('_get_section', '_get_media_config');
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ noarch => 'i586', # noarch packages policy
+ install_root => '',
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ user => '',
+ @_
+ );
+
+ foreach my $var ('arch', 'upload_state') {
+ $self->{"_$var"} = [];
+ foreach my $value (split ' ', $options{$var}) {
+ push @{$self->{"_$var"}}, $value
+ }
+ }
+ print "Initializing repository for @{$self->{_arch}}\n";
+ foreach my $v ('user', 'noarch', 'install_root', 'upload_root', 'verbose') {
+ $self->{"_$v"} = $options{$v}
+ }
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
+ $year+=1900;
+ $mon++;
+ my $hostname = `hostname`;
+ my ($host) = $hostname =~ /([^.]*)/;
+ $self->{group_id} = sprintf "$year%02d%02d%02d%02d%02d.$self->{_user}.$host.${$}_", $mon, $mday, $hour, $min, $sec;
+ $self
+}
+
+sub _get_media_config {
+ my ($self, $target) = @_;
+ my %media;
+ foreach my $arch (@{$self->{_arch}}) {
+ my $root = "$self->{_install_root}/$target/$arch";
+ my $distrib = MDV::Distribconf::Build->new($root);
+ print "Getting media config from $root\n";
+ $self->{distrib}{$arch} = $distrib;
+ $distrib->loadtree or die "$root does not seem to be a distribution tree\n";
+ $distrib->parse_mediacfg;
+ foreach my $media ($distrib->listmedia) {
+ my $rpms = $distrib->getvalue($media, 'rpms');
+ my $debug_for = $distrib->getvalue($media, 'debug_for');
+ my $srpms = $distrib->getvalue($media, 'srpms');
+ my $path = $distrib->getfullpath($media, 'path');
+ if (!$debug_for && !$rpms) {
+ if (-d $path) {
+ print "MEDIA defining $media in $path\n";
+ $media{$arch}{$media} = $path
+ } else {
+ print "ERROR $path does not exist for media $media on $arch\n"
+ }
+ }
+ if ($rpms) {
+ my ($media) = split ' ', $rpms;
+ if (-d $path) {
+ print "MEDIA defining SOURCE media for $media in $path\n";
+ $media{src}{$media} = $path
+ } else {
+ print "ERROR $path does not exist for source media $media on $arch\n"
+ }
+ }
+ }
+ }
+ \%media
+}
+
+sub get_package_class {
+ return PACKAGE_CLASS;
+}
+
+sub get_package_charset {
+ return PACKAGE_CHARSET;
+}
+
+sub get_upload_dir {
+ my ($self, $package, $target, $define, $user) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ print "USER $user\n";
+ return
+ $self->{_upload_root} .
+ "/todo/$target/" .
+ $self->_get_section($package, $target, $define) .
+ "/$self->{group_id}"
+}
+
+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);
+
+ $section
+}
+
+
+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
+ );
+
+ # for each potential section, try to match
+ # a suitable source patten in source directory
+ # a suitable binary patten in binary directory
+ my $media = $self->_get_media_config($target);
+ foreach my $m (keys %{$media->{$arch}}) {
+ next unless
+ $self->get_files(
+ '',
+ $media->{src}{$m},
+ $source_pattern
+ ) || $self->get_files(
+ '',
+ $media->{$arch}{$m},
+ $binary_pattern
+ );
+ print "Section is $m\n";
+ $section = $m;
+ 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_upload_newer_revisions {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ my $name = $package->get_full_name;
+ my $pattern = $self->get_package_class()->get_pattern($package->get_name(), undef, undef, $arch);
+ my $media = $self->_get_media_config($target);
+ my @packages;
+ foreach my $state (@{$self->{_upload_state}}) {
+ foreach my $m (keys %{$media->{$arch}}) {
+ my $path = "$self->{_upload_root}/$state/$target/$m";
+ print "Looking for package $package revisions for $target in $path (pattern $pattern)\n";
+ find(
+ sub {
+ s/([^_]+)_//;
+ return if ! /$pattern/;
+ print "Find $_\n";
+ push @packages, $File::Find::name if $package->compare_ranges("== $name", "< $_")
+ }, $path);
+ }
+ }
+ return
+ @packages;
+}
+
+sub package_in_svn {
+ my ($self, $srpm_name) = @_;
+ my $ctx = new SVN::Client(
+ auth => [SVN::Client::get_simple_provider(),
+ SVN::Client::get_simple_prompt_provider(\&simple_prompt,2),
+ SVN::Client::get_username_provider()]
+ );
+
+ my $svn_entry = $ctx->ls("$self->{_svn}/", 'HEAD', 0);
+ foreach (keys %{$svn_entry}) {
+ if ($srpm_name eq $_) {
+ print "Package $_ is in the SVN\n";
+ return 1
+ }
+ }
+}
+
+sub get_svn_url {
+ my ($self) = @_;
+ $self->{_svn}
+}
+
+# 20060801 warly
+#
+# Upload steps
+# SRPMS are uploaded in /home/mandrake/uploads/todo/$target/$media/group_id
+#
+#
+#
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/Youri/Repository/Mandriva_upload_pre.pm b/lib/Youri/Repository/Mandriva_upload_pre.pm
new file mode 100644
index 0000000..d8c8c68
--- /dev/null
+++ b/lib/Youri/Repository/Mandriva_upload_pre.pm
@@ -0,0 +1,259 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/RSS.pm 857 2006-01-29T10:15:43.298856Z guillaume $
+package Youri::Repository::Mandriva_upload_pre;
+
+=head1 NAME
+
+Youri::Repository::PLF - PLF repository implementation
+
+=head1 DESCRIPTION
+
+This module implements PLF repository.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Memoize;
+use File::Find 'find';
+use base qw/Youri::Repository/;
+use SVN::Client;
+use constant {
+ PACKAGE_CLASS => 'Youri::Package::URPM',
+ PACKAGE_CHARSET => 'utf8'
+};
+
+memoize('_get_section');
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ module => 'SPECS', # CVS module
+ noarch => 'i586', # noarch packages policy
+ svn => '',
+ upload_root => '',
+ @_
+ );
+
+ $self->{_module} = $options{module};
+ $self->{_noarch} = $options{noarch};
+ $self->{_svn} = $options{svn};
+ $self->{_upload_root} = $options{upload_root};
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
+ $year+=1900;
+ my $hostname = `hostname`;
+ my ($host) = $hostname =~ /([^.]*)/;
+ $self->{group_dir} = sprintf "$ENV{SUDO_USER}.$host.$$.$year%02d%02d%02d%02d%02d", $mon, $mday, $hour, $min, $sec;
+}
+
+sub get_package_class {
+ return PACKAGE_CLASS;
+}
+
+sub package_in_svn {
+ my ($self, $srpm_name) = @_;
+ my $ctx = new SVN::Client(
+ auth => [SVN::Client::get_simple_provider(),
+ SVN::Client::get_simple_prompt_provider(\&simple_prompt,2),
+ SVN::Client::get_username_provider()]
+ );
+
+ my $svn_entry = $ctx->ls("$self->{_svn}/", 'HEAD', 0);
+ foreach (keys %{$svn_entry}) {
+ if ($srpm_name eq $_) {
+ print "Package $_ is in the SVN\n";
+ return 1
+ }
+ }
+}
+
+sub get_svn_url {
+ my ($self) = @_;
+ $self->{_svn}
+}
+
+sub get_revisions {
+ my ($self, $package, $target, $define, $filter) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for package $package revisions for $target\n"
+ if $self->{_verbose} > 0;
+
+ my $arch = $package->get_arch;
+ if ($arch eq 'src') {
+ $arch = 'SRPMS'
+ } else {
+ $arch .= '/media'
+ }
+ my @packages =
+ map { $self->get_package_class()->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ "$target/$arch/" . $self->_get_section($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;
+}
+
+sub get_package_charset {
+ return PACKAGE_CHARSET;
+}
+
+sub get_upload_dir {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ my $section = $self->_get_section($package, $target, $define);
+ my $media_path = $section eq 'main' ? $target : $target =~ /^cooker/ ? "contrib" : "$target/contrib";
+ my $arch_path = $arch eq 'src' ? 'SRPMS' : 'RPMS';
+ my $force = $target =~ /_force/ ? 'force' : '';
+ $self->{_upload_root} . "/$media_path/$force/$arch_path/"
+}
+
+sub get_install_path {
+ my ($self, $package, $target, $define) = @_;
+
+ return $self->_get_path($package, $target, $define);
+}
+
+sub get_archive_path {
+ my ($self, $package, $target, $define) = @_;
+
+ return $self->_get_path($package, $target, $define);
+}
+
+sub _get_path {
+ my ($self, $package, $target, $define) = @_;
+
+ my $arch = $package->get_arch;
+ if ($arch eq 'src') {
+ $arch = 'SRPMS'
+ } else {
+ $arch .= '/media'
+ }
+ my $section = $self->_get_section($package, $target, $define);
+
+ return "$target/$arch/$section/release/";
+}
+
+
+sub get_version_path {
+ my ($self, $package, $target, $define) = @_;
+
+ my $section = $self->_get_section($package, $target, $define);
+
+ return "$self->{_module}/$section/release/";
+}
+
+=head2 get_replaced_packages($package, $target, $define)
+
+Overrides parent method to add libified packages.
+
+=cut
+
+sub get_replaced_packages {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my @replaced_packages =
+ $self->SUPER::get_replaced_packages($package, $target, $define);
+
+ # mandriva lib policy:
+ # library package names change with revision, making mandatory to
+ # duplicate older revisions search with a custom pattern
+ my $name = $package->get_name();
+ if ($name =~ /^(lib\w+[a-zA-Z_])[\d_\.]+([-\w]*)$/) {
+ push(@replaced_packages,
+ grep { $package->compare($_) > 0 }
+ map { PACKAGE_CLASS->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ $self->get_install_path($package, $target, $define),
+ PACKAGE_CLASS->get_pattern(
+ $1 . '[\d_\.]+' . $2, # custom name pattern
+ undef,
+ undef,
+ $package->get_arch()
+ ),
+ )
+ );
+ }
+
+ return @replaced_packages;
+
+}
+
+sub _get_section {
+ my ($self, $package, $target, $define) = @_;
+
+ my $section;
+
+ # try to find section automatically
+ my $arch = $package->get_arch();
+
+ my $source_pattern = PACKAGE_CLASS->get_pattern(
+ $package->get_canonical_name(),
+ undef,
+ undef,
+ 'src'
+ );
+
+ my $binary_pattern = PACKAGE_CLASS->get_pattern(
+ $package->get_name(),
+ undef,
+ undef,
+ $arch
+ );
+
+ # for each potential section, try to match
+ # a suitable source patten in source directory
+ # a suitable binary patten in binary directory
+ foreach my $dir (qw/main contrib/) {
+ print "Checking $self->{_install_root}, SRPMS/$dir, $source_pattern\n" if $self->{_verbose};
+ next unless
+ $self->get_files(
+ $self->{_install_root},
+ "$target/SRPMS/$dir/release",
+ $source_pattern
+ ) || $self->get_files(
+ $self->{_install_root},
+ "$target/$arch/media/$dir/release",
+ $binary_pattern
+ );
+ print "Section is $dir\n";
+ $section = $dir;
+ last;
+ }
+
+ # use defined section if not found
+ $section = $define->{section} unless $section;
+
+ $section || 'contrib'
+}
+
+sub get_upload_newer_revisions {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+ my $pattern = $self->get_package_class()->get_pattern($package->get_name());
+ print "Looking for package $package revisions for $target in $self->{_upload_root} (pattern $pattern)\n";
+ my @packages;
+ find(sub { return if ! /$pattern/; print "Find $_\n"; push @packages, $File::Find::name if $package->compare($self->get_package_class()->new(file => $File::Find::name)) <= 0 }, $self->{_upload_root});
+
+ return
+ @packages;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/Youri/Upload/Action/Markrelease.pm b/lib/Youri/Upload/Action/Markrelease.pm
new file mode 100644
index 0000000..2a3b8a5
--- /dev/null
+++ b/lib/Youri/Upload/Action/Markrelease.pm
@@ -0,0 +1,55 @@
+# $Id: Install.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Action::Markrelease;
+
+=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,
+ @_
+ );
+
+ return $self;
+}
+
+sub run {
+ my ($self, $package, $repository, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ $package->is_source or return 1;
+ my $file = $package->get_file();
+ my $srpm_name = $package->get_canonical_name;
+
+ if ($repository->package_in_svn($srpm_name)) {
+ my $svn = $repository->get_svn_url();
+ print "Run repsys markrelease -f $file $svn/$srpm_name\n";
+ # FIXME repsys ask for a username and password
+ # FIXME we should use the key in /var/home/mandrake so that /home/mandrake does not
+ # need to be mounted
+ system('repsys', 'markrelease', '-f', $file, "$svn/$srpm_name");
+ }
+ 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/Action/Send.pm b/lib/Youri/Upload/Action/Send.pm
new file mode 100644
index 0000000..77c3b2a
--- /dev/null
+++ b/lib/Youri/Upload/Action/Send.pm
@@ -0,0 +1,72 @@
+# $Id: Install.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Action::Send;
+
+=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,
+ uphost => '',
+ user => '',
+ ssh_key => '',
+ verbose => '',
+ @_
+ );
+ croak "undefined upload host" unless $options{uphost};
+ croak "undefined ssh key" unless $options{ssh_key};
+
+ $self->{_perms} = $options{perms};
+ $self->{_user} = $options{user};
+ $self->{_uphost} = $options{uphost};
+ $self->{_ssh_key} = $options{ssh_key};
+ $self->{_verbose} = $options{verbose};
+
+ 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_upload_dir($package, $target, $define);
+
+ print "Sending file $file to $dest\n" if $self->{_verbose};
+ my ($base) = $file =~ /.*\/(?:@\d+:)?([^\/]*)/;
+
+ my $cmd = "scp -i $self->{_ssh_key} $file $self->{_user}\@$self->{_uphost}:/$dest$base.new";
+ my $cmd2 = "ssh -i $self->{_ssh_key} $self->{_user}\@$self->{_uphost} \"mv /$dest$base.new /$dest$base\"";
+ print "Upload::Action::Send: doing $cmd\n$cmd2\n" if 1 || $self->{_verbose};
+ if (!$self->{_test}) {
+ if (!system($cmd)) {
+ if (!system($cmd2)) {
+ print "Upload::Action::Send: upload succeeded!\n";
+ return 1
+ }
+ }
+ print "Upload::Action::Send: upload failed!\n";
+ }
+}
+=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/ACL.pm b/lib/Youri/Upload/Check/ACL.pm
new file mode 100644
index 0000000..e231500
--- /dev/null
+++ b/lib/Youri/Upload/Check/ACL.pm
@@ -0,0 +1,74 @@
+# $Id: Tag.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Check::ACL;
+
+=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 strict;
+use Carp;
+use base qw/Youri::Upload::Check/;
+my $acl;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ acl_file => '',
+ user => '',
+ @_
+ );
+ $self->{_user} = $options{user};
+ $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 = $self->{_user};
+ foreach my $t (keys %$acl) {
+ next if $target !~ /$t/;
+ foreach my $acl (@{$acl->{$t}}) {
+ my ($arch, $media, $r, $users) = @$acl;
+ next if $arch !~ $a || $srpm !~ $r || $media !~ $media;
+ if ($user =~ /$users/) {
+ return 1
+ } else {
+ $self->{_error} = "$user is not authorized to upload packages belonging to $srpm (authorized persons: " . join(', ', split '\|', $users) . ")";
+ return 0
+ }
+ }
+ }
+ 1
+}
+
+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/Upload/Check/Host.pm b/lib/Youri/Upload/Check/Host.pm
new file mode 100644
index 0000000..d6cae8d
--- /dev/null
+++ b/lib/Youri/Upload/Check/Host.pm
@@ -0,0 +1,64 @@
+# $Id: Tag.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Check::Host;
+
+=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 strict;
+use Carp;
+use base qw/Youri::Upload::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->get_buildhost;
+ foreach my $h (keys %$host) {
+ next if $buildhost !~ $h;
+ if ($arch =~ $host->{$h}) {
+ return 1
+ }
+ }
+ $self->{_error} = "Packages build on host $buildhost are not authorized";
+ 0
+}
+
+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/Upload/Check/Queue_recency.pm b/lib/Youri/Upload/Check/Queue_recency.pm
new file mode 100644
index 0000000..f7f5940
--- /dev/null
+++ b/lib/Youri/Upload/Check/Queue_recency.pm
@@ -0,0 +1,42 @@
+# $Id: Recency.pm 873 2006-04-15 17:04:27Z guillomovitch $
+package Youri::Upload::Check::Queue_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 @newer_revisions =
+ $repository->get_upload_newer_revisions($package, $target, $define);
+ if (@newer_revisions) {
+ $self->{_error} = "Newer revisions already exists for $target in upload queue: " . 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/Recency.pm b/lib/Youri/Upload/Check/Recency.pm
index d6fc920..0cf4a85 100644
--- a/lib/Youri/Upload/Check/Recency.pm
+++ b/lib/Youri/Upload/Check/Recency.pm
@@ -22,6 +22,7 @@ sub run {
croak "Not a class method" unless ref $self;
my $file = $repository->get_install_file($package, $target, $define);
+ print "Recency: looking for $file\n" if $self->{_verbose};
if (-f $file) {
$self->{_error} = "Current revision already exists for $target";
return 0;
diff --git a/lib/Youri/Upload/Check/Rpmlint.pm b/lib/Youri/Upload/Check/Rpmlint.pm
new file mode 100644
index 0000000..08d5e56
--- /dev/null
+++ b/lib/Youri/Upload/Check/Rpmlint.pm
@@ -0,0 +1,57 @@
+# $Id: Tag.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Check::Rpmlint;
+
+=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 = (
+ fatal_error => '',
+ @_
+ );
+ $self->{_fatal_error} = $options{fatal_error};
+}
+
+sub run {
+ my ($self, $package, $repository, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $file = $package->get_file;
+ open my $rpmlint, "rpmlint $file |";
+ my $fatal;
+ my $error = "fatal errors detected, upload rejected:\n";
+ while (<$rpmlint>) {
+ if (/$self->{_fatal_error}/) {
+ $fatal = 1;
+ $error .= "- $_"
+ }
+ }
+ if ($fatal) {
+ $self->{_error} = $error;
+ return 0
+ }
+ 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/SVN.pm b/lib/Youri/Upload/Check/SVN.pm
new file mode 100644
index 0000000..5533dde
--- /dev/null
+++ b/lib/Youri/Upload/Check/SVN.pm
@@ -0,0 +1,74 @@
+# $Id: Tag.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Check::SVN;
+
+=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 = (
+ svn => '',
+ @_
+ );
+ $self->{_svn} = $options{svn};
+}
+
+sub run {
+ my ($self, $package, $repository, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ $package->is_source or return 1;
+ my $file = $package->get_file_name;
+ my $srpm_name = $package->get_canonical_name;
+ if ($repository->package_in_svn($srpm_name)) {
+ if ($file !~ /^@\d+:\Q$srpm_name/) {
+ $self->{_error} = "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)";
+ return 0
+ } else {
+ print "Package $file is correct\n";
+ return 1
+ }
+ }
+ 1
+}
+
+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/Upload/Check/Source.pm b/lib/Youri/Upload/Check/Source.pm
new file mode 100644
index 0000000..7d8ea03
--- /dev/null
+++ b/lib/Youri/Upload/Check/Source.pm
@@ -0,0 +1,47 @@
+# $Id: Tag.pm 867 2006-04-11 20:34:56Z guillomovitch $
+package Youri::Upload::Check::Source;
+
+=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 = (
+ @_
+ );
+}
+
+sub run {
+ my ($self, $package, $repository, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+ my $file = $package->get_file();
+ if (!$package->is_source()) {
+ print
+ $self->{_error} = "Package $file is not a source rpm";
+ 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;
generated by cgit v1.2.1 (git 2.21.0) at 2024-09-19 12:09:37 +0000