aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorPascal Rigaux <pixel@mandriva.com>2007-06-29 13:30:24 +0000
committerPascal Rigaux <pixel@mandriva.com>2007-06-29 13:30:24 +0000
commit6cbb51a6bf5f4ccfc3388ce39a3bbd5b14a91217 (patch)
tree7e5723a41d828799e9759547bfd72c0133ba297f /lib
downloadmga-youri-submit-6cbb51a6bf5f4ccfc3388ce39a3bbd5b14a91217.tar
mga-youri-submit-6cbb51a6bf5f4ccfc3388ce39a3bbd5b14a91217.tar.gz
mga-youri-submit-6cbb51a6bf5f4ccfc3388ce39a3bbd5b14a91217.tar.bz2
mga-youri-submit-6cbb51a6bf5f4ccfc3388ce39a3bbd5b14a91217.tar.xz
mga-youri-submit-6cbb51a6bf5f4ccfc3388ce39a3bbd5b14a91217.zip
prepare mergeupstream
Diffstat (limited to 'lib')
-rw-r--r--lib/Makefile.am34
-rw-r--r--lib/Youri/Submit/Action/Archive.pm73
-rw-r--r--lib/Youri/Submit/Action/Bugzilla.pm78
-rw-r--r--lib/Youri/Submit/Action/CVS.pm136
-rw-r--r--lib/Youri/Submit/Action/Clean.pm42
-rw-r--r--lib/Youri/Submit/Action/Install.pm74
-rw-r--r--lib/Youri/Submit/Action/Link.pm79
-rw-r--r--lib/Youri/Submit/Action/Mail.pm143
-rw-r--r--lib/Youri/Submit/Action/RSS.pm117
-rw-r--r--lib/Youri/Submit/Action/Reorder.pm37
-rw-r--r--lib/Youri/Submit/Action/Sign.pm60
-rw-r--r--lib/Youri/Submit/Step.pm125
-rw-r--r--lib/Youri/Submit/Test/History.pm65
-rw-r--r--lib/Youri/Submit/Test/Precedence.pm60
-rw-r--r--lib/Youri/Submit/Test/Recency.pm50
-rw-r--r--lib/Youri/Submit/Test/Rpmlint.pm97
-rw-r--r--lib/Youri/Submit/Test/Set.pm79
-rw-r--r--lib/Youri/Submit/Test/Tag.pm58
18 files changed, 1407 insertions, 0 deletions
diff --git a/lib/Makefile.am b/lib/Makefile.am
new file mode 100644
index 0000000..40ae36a
--- /dev/null
+++ b/lib/Makefile.am
@@ -0,0 +1,34 @@
+nobase_perllib_DATA = Youri/Submit/Test/Rpmlint.pm \
+ Youri/Submit/Test/Recency.pm \
+ Youri/Submit/Test/Tag.pm \
+ Youri/Submit/Test/Precedence.pm \
+ Youri/Submit/Test/History.pm \
+ Youri/Submit/Test/Type.pm \
+ Youri/Submit/Action.pm \
+ Youri/Submit/Plugin.pm \
+ Youri/Submit/Test.pm \
+ Youri/Submit/Action/Install.pm \
+ Youri/Submit/Action/RSS.pm \
+ Youri/Submit/Action/Bugzilla.pm \
+ Youri/Submit/Action/CVS.pm \
+ Youri/Submit/Action/Link.pm \
+ Youri/Submit/Action/Sign.pm \
+ Youri/Submit/Action/Archive.pm \
+ Youri/Submit/Action/Clean.pm \
+ Youri/Submit/Action/Mail.pm
+
+EXTRA_DIST = $(nobase_perllib_DATA)
+
+install-data-hook:
+ $(INSTALL) -d -m 755 $(DESTDIR)$(mandir)/man3
+ for file in $(nobase_perllib_DATA); do \
+ page=`echo $$file | sed -e 's/\//::/g' -e 's/\.pm$$/.3pm/'`; \
+ $(POD2MAN) --section=3 $(srcdir)/$$file \
+ $(DESTDIR)$(mandir)/man3/$$page; \
+ done
+
+uninstall-hook:
+ for file in $(nobase_perllib_DATA); do \
+ page=`echo $$file | sed -e 's/\//::/g' -e 's/\.pm$$/.3pm/'`; \
+ rm -f $(DESTDIR)$(mandir)/man3/$$page; \
+ done
diff --git a/lib/Youri/Submit/Action/Archive.pm b/lib/Youri/Submit/Action/Archive.pm
new file mode 100644
index 0000000..75e69cb
--- /dev/null
+++ b/lib/Youri/Submit/Action/Archive.pm
@@ -0,0 +1,73 @@
+# $Id: Archive.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Archive;
+
+=head1 NAME
+
+Youri::Submit::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::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ perms => 644,
+ @_
+ );
+
+ $self->{_perms} = $options{perms};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ foreach my $package (@$packages) {
+ foreach my $replaced_package (
+ $repository->get_replaced_packages($package, $target, $context)
+ ) {
+ my $file = $replaced_package->as_file();
+ my $dest = $repository->get_archive_dir($package, $target, $context);
+
+ print "archiving file $file to $dest\n" if $self->{_verbose};
+
+ unless ($self->{_test}) {
+ # create destination dir if needed
+ if (! -d $dest) {
+ eval {
+ mkpath($dest, 0, ($self->{_perms} + 111));
+ };
+ if ($@) {
+ croak "Unable to create directory $dest: $@";
+ }
+ }
+
+ # copy file to new location
+ copy($file, $dest)
+ or croak "Unable to copy file $file to $dest: $!";
+
+ # set permissions
+ chmod oct($self->{_perms}), $dest . '/' . basename($file)
+ or croak "Unable to set perms of file $file to $self->{_perms}: $!";
+ }
+ }
+ }
+}
+
+=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/Action/Bugzilla.pm b/lib/Youri/Submit/Action/Bugzilla.pm
new file mode 100644
index 0000000..a8ad5ce
--- /dev/null
+++ b/lib/Youri/Submit/Action/Bugzilla.pm
@@ -0,0 +1,78 @@
+# $Id: Bugzilla.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Bugzilla;
+
+=head1 NAME
+
+Youri::Submit::Action::Bugzilla - Bugzilla synchronisation
+
+=head1 DESCRIPTION
+
+This action ensures synchronisation with Bugzilla. It assumes given package set
+is canonical, with source package first.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::BTS::Bugzilla;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ lib => undef,
+ project => undef,
+ contact => undef,
+ @_
+ );
+
+ $self->{_bugzilla} = Youri::BTS::Bugzilla->new(
+ $options{lib} ? (lib => $options{lib}) : (),
+ $options{project} ? (project => $options{project}) : (),
+ );
+ $self->{_contact} = $options{contact};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $package = $packages->[0];
+
+ 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/Submit/Action/CVS.pm b/lib/Youri/Submit/Action/CVS.pm
new file mode 100644
index 0000000..48e3eae
--- /dev/null
+++ b/lib/Youri/Submit/Action/CVS.pm
@@ -0,0 +1,136 @@
+# $Id: CVS.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::CVS;
+
+=head1 NAME
+
+Youri::Submit::Action::CVS - CVS versionning
+
+=head1 DESCRIPTION
+
+This action ensures CVS versionning of package sources. It assumes given
+package set is canonical, with source package first.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Cwd;
+use File::Temp qw/tempdir/;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ exclude => '\.(tar(\.(gz|bz2))?|zip)$',
+ perms => 644,
+ @_
+ );
+
+ $self->{_exclude} = $options{exclude};
+ $self->{_perms} = $options{perms};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $package = $packages->[0];
+
+ 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/Submit/Action/Clean.pm b/lib/Youri/Submit/Action/Clean.pm
new file mode 100644
index 0000000..110326a
--- /dev/null
+++ b/lib/Youri/Submit/Action/Clean.pm
@@ -0,0 +1,42 @@
+# $Id: Clean.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Clean;
+
+=head1 NAME
+
+Youri::Submit::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::Submit::Step/;
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ foreach my $package (@$packages) {
+ foreach my $replaced_package (
+ $repository->get_replaced_packages($package, $target, $define)
+ ) {
+ my $file = $replaced_package->as_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/Submit/Action/Install.pm b/lib/Youri/Submit/Action/Install.pm
new file mode 100644
index 0000000..c9a419f
--- /dev/null
+++ b/lib/Youri/Submit/Action/Install.pm
@@ -0,0 +1,74 @@
+# $Id: Install.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Install;
+
+=head1 NAME
+
+Youri::Submit::Action::Install - Package installation
+
+=head1 DESCRIPTION
+
+This action plugin ensures installation of new package revisions.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use File::Copy;
+use File::Path;
+use File::Basename;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ perms => 644,
+ @_
+ );
+
+ $self->{_perms} = $options{perms};
+
+ return $self;
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ foreach my $package (@$packages) {
+ my $file = $package->as_file();
+ my $dest = $repository->get_install_dir($package, $target, $context);
+
+ print "installing file $file to $dest\n" if $self->{_verbose};
+
+ unless ($self->{_test}) {
+ # create destination dir if needed
+ if (! -d $dest) {
+ eval {
+ mkpath($dest, 0, ($self->{_perms} + 111));
+ };
+ if ($@) {
+ croak "Unable to create directory $dest: $@";
+ }
+ }
+
+ # copy file to new location
+ copy($file, $dest)
+ or croak "Unable to copy file $file to $dest: $!";
+
+ # set permissions
+ chmod oct($self->{_perms}), $dest . '/' . basename($file)
+ or croak "Unable to set perms of file $file to $self->{_perms}: $!";
+ }
+ }
+}
+
+=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/Action/Link.pm b/lib/Youri/Submit/Action/Link.pm
new file mode 100644
index 0000000..940f7d7
--- /dev/null
+++ b/lib/Youri/Submit/Action/Link.pm
@@ -0,0 +1,79 @@
+# $Id: Link.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Link;
+
+=head1 NAME
+
+Youri::Submit::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 Cwd;
+use File::Spec;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ symbolic => 0, # use symbolic linking
+ @_
+ );
+
+ $self->{_symbolic} = $options{symbolic};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ foreach my $package (@$packages) {
+ # only needed for noarch packages
+ next unless $package->get_arch() eq 'noarch';
+
+ my $default_dir = $repository->get_install_dir($package, $target, $define);
+ my $file = $package->get_file_name();
+
+ foreach my $arch ($repository->get_extra_arches()) {
+ # compute installation target, forcing arch
+ my $other_dir = $repository->get_install_dir(
+ $package,
+ $target,
+ $context,
+ { arch => $arch }
+ );
+
+ if (! $self->{_test} && -d $other_dir) {
+ my $current_dir = cwd();
+ chdir $other_dir
+ or croak "Can't change directory to $other_dir: $!";
+ my $default_file = File::Spec->abs2rel($default_dir) . '/' . $file;
+ if ($self->{_symbolic}) {
+ symlink $default_file, $file
+ or croak "Can't symlink $default_file to $file: $!";
+ } else {
+ link $default_file, $file
+ or croak "Can't link $default_file to $file: $!";
+ }
+ chdir $current_dir
+ or croak "Can't change directory to $current_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/Submit/Action/Mail.pm b/lib/Youri/Submit/Action/Mail.pm
new file mode 100644
index 0000000..4e39ef8
--- /dev/null
+++ b/lib/Youri/Submit/Action/Mail.pm
@@ -0,0 +1,143 @@
+# $Id: Mail.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Mail;
+
+=head1 NAME
+
+Youri::Submit::Action::Mail - Mail notification
+
+=head1 DESCRIPTION
+
+This action ensures mail notification of new package revisions. It assumes
+given package set is canonical, with source package first.
+
+=cut
+
+use warnings;
+use strict;
+use MIME::Entity;
+use Encode qw/from_to/;
+use Carp;
+use Youri::Package;
+use base qw/Youri::Submit::Step/;
+
+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 process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $package = $packages->[0];
+
+ my $from = $package->get_packager();
+
+ # force from adress if defined
+ $from =~ s/<.*>/<$self->{_from}>/ if $self->{_from};
+
+ my $subject = $self->get_subject($package, $repository, $target, $define);
+ my $content = $self->get_content($package, $repository, $target, $define);
+
+ # 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 {
+ my $command = "$self->{_mta} -t -oi -oem";
+ open(my $output, '|-', $command) or croak "Can't run $command: $!";
+ $mail->print($output);
+ close $output;
+ }
+
+}
+
+sub get_subject {
+ my ($self, $package, $repository, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ ($self->{_prefix} ? '[' . $self->{_prefix} . '] ' : '' ) .
+ $package->as_formated_string('%{name}-%{version}-%{release}');
+}
+
+sub get_content {
+ my ($self, $package, $repository, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $information = $package->as_formated_string(<<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
+
+ my $last_change = $package->get_last_change();
+
+ return $last_change ?
+ $information . "\n" .
+ $last_change->get_author() . ":\n" .
+ $last_change->get_raw_text() :
+ $information;
+}
+
+
+=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/Action/RSS.pm b/lib/Youri/Submit/Action/RSS.pm
new file mode 100644
index 0000000..11fb5b5
--- /dev/null
+++ b/lib/Youri/Submit/Action/RSS.pm
@@ -0,0 +1,117 @@
+# $Id: RSS.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::RSS;
+
+=head1 NAME
+
+Youri::Submit::Action::RSS - RSS notification
+
+=head1 DESCRIPTION
+
+This action ensures RSS notification of new package revisions. It assumes given package set is canonical, with source package first.
+
+=cut
+
+use warnings;
+use strict;
+use XML::RSS;
+use Encode qw/from_to/;
+use Carp;
+use base qw/Youri::Submit::Step/;
+
+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 process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $package = $packages->[0];
+
+ my $subject = $package->as_formated_string('%{name}-%{version}-%{release}');
+ my $content = $package->as_formated_string(<<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
+
+ $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) {
+ eval {
+ $rss->parsefile($file);
+ };
+ if ($@) {
+ croak "Unable to parse RSS file $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/Submit/Action/Reorder.pm b/lib/Youri/Submit/Action/Reorder.pm
new file mode 100644
index 0000000..a6ed3da
--- /dev/null
+++ b/lib/Youri/Submit/Action/Reorder.pm
@@ -0,0 +1,37 @@
+# $Id: Reorder.pm 1688 2007-06-28 22:44:16Z guillomovitch $
+package Youri::Submit::Action::Reorder;
+
+=head1 NAME
+
+Youri::Submit::Action::Reorder - Reorder packages with source first
+
+=head1 DESCRIPTION
+
+This action ensures that the source package is the first in the list.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base qw/Youri::Submit::Step/;
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ $packages = [
+ grep { $_->is_source() } @$packages,
+ grep { !$_->is_source() } @$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/Submit/Action/Sign.pm b/lib/Youri/Submit/Action/Sign.pm
new file mode 100644
index 0000000..ce8f4a9
--- /dev/null
+++ b/lib/Youri/Submit/Action/Sign.pm
@@ -0,0 +1,60 @@
+# $Id: Sign.pm 1689 2007-06-28 22:44:24Z guillomovitch $
+package Youri::Submit::Action::Sign;
+
+=head1 NAME
+
+Youri::Submit::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::Submit::Step/;
+
+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 process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return if $self->{_test};
+
+ foreach my $package (@$packages) {
+ $package->sign(
+ $self->{_name},
+ $self->{_path},
+ $self->{_passphrase}
+ );
+ }
+}
+
+=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/Step.pm b/lib/Youri/Submit/Step.pm
new file mode 100644
index 0000000..0085277
--- /dev/null
+++ b/lib/Youri/Submit/Step.pm
@@ -0,0 +1,125 @@
+# $Id: Step.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Step;
+
+=head1 NAME
+
+Youri::Submit::Step - Abstract submission step
+
+=head1 DESCRIPTION
+
+This abstract class defines youri-submit plugin interface.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Submit::Plugin object.
+
+Generic parameters:
+
+=over
+
+=item skip $skip
+
+List of packages for which to skip this plugin
+
+=over
+
+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
+ skip => undef,
+ @_
+ );
+
+ croak "skip should be an arrayref"
+ if $options{skip} and ref $options{skip} ne 'ARRAY';
+
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ _skip => { map { $_ => 1 } @{$options{skip}} }
+ }, $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($packages, $repository, $target, $context)
+
+Execute action on given L<Youri::Package> object.
+
+=cut
+
+sub run {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+ croak "packages is not an array reference" unless ref $packages eq 'ARRAY';
+
+ # filter exceptions
+ $packages = [
+ grep { !$self->{_skip}->{$_->get_canonical_name()} }
+ @$packages
+ ];
+
+ $self->process_packages($repository, $packages, $target, $context)
+ if @$packages;
+}
+
+
+=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/Submit/Test/History.pm b/lib/Youri/Submit/Test/History.pm
new file mode 100644
index 0000000..b4b7969
--- /dev/null
+++ b/lib/Youri/Submit/Test/History.pm
@@ -0,0 +1,65 @@
+# $Id: History.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Test::History;
+
+=head1 NAME
+
+Youri::Submit::Test::History - Non-linear history test
+
+=head1 DESCRIPTION
+
+This test rejects packages whose history does not include last available
+revision one. It assumes given set of package is canonical, and only check
+first one.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Package;
+use List::MoreUtils qw/none/;
+use base qw/Youri::Submit::Step/;
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $errors;
+ my $package = $packages->[0];
+ my $current_package =
+ $repository->get_last_older_revision($package, $target, $context);
+
+ # new package
+ return unless $current_package;
+
+ # skip the test if last revision has been produced from another
+ # source package, as it occurs during package split/merges
+ return
+ if $current_package->get_canonical_name()
+ ne $package->get_canonical_name();
+
+ my $last_change_author =
+ $current_package->get_last_change()->get_author();
+
+ if (
+ none { $last_change_author eq $_ }
+ map { $_->get_author() }
+ $package->get_changes()
+ ) {
+ $errors .=
+ "last changelog entry $last_change_author from current package "
+ . "$current_package missing from changelog";
+ }
+
+ croak $errors if $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/Precedence.pm b/lib/Youri/Submit/Test/Precedence.pm
new file mode 100644
index 0000000..4cd35a6
--- /dev/null
+++ b/lib/Youri/Submit/Test/Precedence.pm
@@ -0,0 +1,60 @@
+# $Id: Precedence.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Test::Precedence;
+
+=head1 NAME
+
+Youri::Submit::Test::Precedence - Release test against another test
+
+=head1 DESCRIPTION
+
+This test rejects packages whose an older revision already exists for another
+upload target. It assumes given set of package is canonical, and only check
+first one.
+
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ _target => undef, # mandatory targets
+ @_
+ );
+
+ croak "undefined target" unless $options{target};
+
+ $self->{_target} = $options{target};
+}
+
+sub process_package {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $errors;
+ my $package = $packages->[0];
+
+ my @older_revisions =
+ $repository->get_older_revisions($package, $self->{_target}, $context);
+ $errors .=
+ "older revisions still exists for $self->{_target}: "
+ . join(', ', @older_revisions)
+ if @older_revisions;
+ }
+
+ croak $errors if $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/Recency.pm b/lib/Youri/Submit/Test/Recency.pm
new file mode 100644
index 0000000..db6ba59
--- /dev/null
+++ b/lib/Youri/Submit/Test/Recency.pm
@@ -0,0 +1,50 @@
+# $Id: Recency.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Test::Recency;
+
+=head1 NAME
+
+Youri::Submit::Test::Recency - Release test against current target
+
+=head1 DESCRIPTION
+
+This test rejects packages whose a current or newer revision already exists for
+current upload target. It assumes given set of package is canonical, and only
+check first one.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base qw/Youri::Submit::Step/;
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $errors;
+ my $package = $packages->[0];
+
+ my $file = $repository->get_install_file($package, $target, $context);
+ $errors .= "current revision already exists for $target\n"
+ if -f $file;
+
+ my @newer_revisions =
+ $repository->get_newer_revisions($package, $target, $define);
+ $errors .=
+ "newer revisions already exists for $target: "
+ . join(', ', @newer_revisions) . "\n"
+ if @newer_revisions;
+
+ croak $errors if $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..170d4c3
--- /dev/null
+++ b/lib/Youri/Submit/Test/Rpmlint.pm
@@ -0,0 +1,97 @@
+# $Id: Rpmlint.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Test::Rpmlint;
+
+=head1 NAME
+
+Youri::Submit::Test::Rpmlint - Rpmlint-based test
+
+=head1 DESCRIPTION
+
+This test plugin wraps rpmlint, and reject packages triggering results
+declared as fatal.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base qw/Youri::Submit::Step/;
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Submit::Test::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 test" unless $options{results};
+ croak "results should be an arrayref" unless ref $options{results} eq 'ARRAY';
+
+ $self->{_results} = map { $_ => 1 } @{$options{results}};
+ $self->{_path} = $options{path};
+ $self->{_config} = $options{config};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $errors;
+
+ foreach my $package (@$packages) {
+ my $command =
+ $self->{_path} . ' ' .
+ ($self->{_config} ? "-f $self->{_config} " : '' ) .
+ $package->as_file();
+
+ open(my $input, '-|', $command) or croak "Can't run $command: $!";
+ my $pattern = qr/^[EW]: \S+ (\S+) (.*)$/;
+ while (my $line = <$input>) {
+ next unless $line =~ $pattern;
+ my $id = $1;
+ my $value = $2;
+ $errors .= "$id $value"
+ if $self->{_results}->{$id};
+ }
+ close $input;
+ }
+
+ croak $errors if $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/Set.pm b/lib/Youri/Submit/Test/Set.pm
new file mode 100644
index 0000000..2ed4994
--- /dev/null
+++ b/lib/Youri/Submit/Test/Set.pm
@@ -0,0 +1,79 @@
+# $Id: Set.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Test::Set;
+
+=head1 NAME
+
+Youri::Submit::Test::Set - Packages set test
+
+=head1 DESCRIPTION
+
+This test rejects non-canonical packages set, meaning packages generated from
+different sources packages, checking expected number or source and binaries
+packages.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use List::MoreUtils qw/all/;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ min_sources => 1,
+ max_sources => 1,
+ min_binaries => 1,
+ max_binaries => undef,
+ @_
+ );
+
+ $self->{_min_sources} = $options{min_sources};
+ $self->{_max_sources} = $options{max_sources};
+ $self->{_min_binaries} = $options{min_binaries};
+ $self->{_max_binaries} = $options{max_binaries};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $errors;
+
+ if (@$packages > 1) {
+ my $name = $packages->[0]->get_canonical_name();
+ $errors .= "not a canonical package set\n"
+ unless
+ all { $_->get_canonical_name() eq $name }
+ @$packages;
+ }
+
+ my $sources = grep { $_->is_source() } @$packages;
+
+ $errors .= "number of source packages > $self->{_max_sources}\n"
+ if defined $self->{_max_sources} && $sources > $self->{_max_sources};
+
+ $errors .= "number of source packages < $self->{_min_sources}\n"
+ if defined $self->{_min_sources} && $sources < $self->{_min_sources};
+
+ my $binaries = grep { $_->is_binary() } @$packages;
+
+ $errors .= "number of binary packages > $self->{_max_binaries}\n"
+ if defined $self->{_max_binaries} && $binaries > $self->{_max_binaries};
+
+ $errors .= "number of binary packages < $self->{_min_binaries}\n"
+ if defined $self->{_min_binaries} && $binaries < $self->{_min_binaries};
+
+ croak $errors if $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/Tag.pm b/lib/Youri/Submit/Test/Tag.pm
new file mode 100644
index 0000000..59342e4
--- /dev/null
+++ b/lib/Youri/Submit/Test/Tag.pm
@@ -0,0 +1,58 @@
+# $Id: Tag.pm 1687 2007-06-28 22:44:07Z guillomovitch $
+package Youri::Submit::Test::Tag;
+
+=head1 NAME
+
+Youri::Submit::Test::Tag - Incorrect tag values test
+
+=head1 DESCRIPTION
+
+This test plugin rejects packages with incorrect tag values, based on regular
+expressions.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base qw/Youri::Submit::Step/;
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ tags => undef, # expected tag values
+ @_
+ );
+
+ croak "no tags to test" unless $options{tags};
+ croak "tag should be an hashref" unless ref $options{tags} eq 'HASH';
+
+ $self->{_tags} = $options{tags};
+}
+
+sub process_packages {
+ my ($self, $packages, $repository, $target, $context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $errors;
+
+ foreach my $package (@$packages) {
+ foreach my $tag (keys %{$self->{_tags}}) {
+ my $value = $package->get_tag($tag);
+ $errors .= "invalid value $value for tag $tag"
+ if $value !~ /$self->{_tags}->{$tag}/;
+ }
+ }
+
+ croak $errors if $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;