[Mageia-sysadm] [210] add mandriva version of youri-core, downloaded from http://svn. mandriva.com/svn/soft/build_system/youri/core/trunk/ at revision 271600
root at mageia.org
root at mageia.org
Wed Jan 5 14:23:45 CET 2011
Revision: 210
Author: boklm
Date: 2011-01-05 14:23:45 +0100 (Wed, 05 Jan 2011)
Log Message:
-----------
add mandriva version of youri-core, downloaded from http://svn.mandriva.com/svn/soft/build_system/youri/core/trunk/ at revision 271600
Added Paths:
-----------
build_system/mdv-youri-core/
build_system/mdv-youri-core/branches/
build_system/mdv-youri-core/tags/
build_system/mdv-youri-core/trunk/
build_system/mdv-youri-core/trunk/ChangeLog
build_system/mdv-youri-core/trunk/MANIFEST.SKIP
build_system/mdv-youri-core/trunk/Makefile.PL
build_system/mdv-youri-core/trunk/README
build_system/mdv-youri-core/trunk/TODO
build_system/mdv-youri-core/trunk/bin/
build_system/mdv-youri-core/trunk/bin/fillbugzilla
build_system/mdv-youri-core/trunk/cgi/
build_system/mdv-youri-core/trunk/cgi/maintainers.cgi
build_system/mdv-youri-core/trunk/etc/
build_system/mdv-youri-core/trunk/etc/bash_completion.d/
build_system/mdv-youri-core/trunk/etc/bash_completion.d/youri
build_system/mdv-youri-core/trunk/etc/check.conf
build_system/mdv-youri-core/trunk/etc/upload.conf
build_system/mdv-youri-core/trunk/lib/
build_system/mdv-youri-core/trunk/lib/Youri/
build_system/mdv-youri-core/trunk/lib/Youri/Bugzilla.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Age.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/Iurt.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/LBD.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Conflicts.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Dependencies.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/MandrivaConflicts.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Missing.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Orphans.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Rpmlint.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Signature.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/CPAN.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Debian.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Fedora.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/GNOME.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Gentoo.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/NetBSD.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/RAA.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Input.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences/File.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/CGI.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/HTML.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/RSS.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/Text.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/HTML.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/Text.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Output.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/
build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/DBI.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/Iterator.pm
build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset.pm
build_system/mdv-youri-core/trunk/lib/Youri/Config.pm
build_system/mdv-youri-core/trunk/lib/Youri/Media/
build_system/mdv-youri-core/trunk/lib/Youri/Media/URPM.pm
build_system/mdv-youri-core/trunk/lib/Youri/Media.pm
build_system/mdv-youri-core/trunk/lib/Youri/Package/
build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM.pm
build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM4.pm
build_system/mdv-youri-core/trunk/lib/Youri/Package/Test.pm
build_system/mdv-youri-core/trunk/lib/Youri/Package/URPM.pm
build_system/mdv-youri-core/trunk/lib/Youri/Package.pm
build_system/mdv-youri-core/trunk/lib/Youri/Repository/
build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload.pm
build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload_pre.pm
build_system/mdv-youri-core/trunk/lib/Youri/Repository/PLF.pm
build_system/mdv-youri-core/trunk/lib/Youri/Repository.pm
build_system/mdv-youri-core/trunk/lib/Youri/Utils.pm
build_system/mdv-youri-core/trunk/t/
build_system/mdv-youri-core/trunk/t/00distribution.t
build_system/mdv-youri-core/trunk/t/cowsay-3.03-11mdv2007.0.noarch.rpm
build_system/mdv-youri-core/trunk/t/gpghome/
build_system/mdv-youri-core/trunk/t/gpghome/pubring.gpg
build_system/mdv-youri-core/trunk/t/gpghome/secring.gpg
build_system/mdv-youri-core/trunk/t/gpghome/trustdb.gpg
build_system/mdv-youri-core/trunk/t/package.t
build_system/mdv-youri-core/trunk/t/version.t
Added: build_system/mdv-youri-core/trunk/ChangeLog
===================================================================
--- build_system/mdv-youri-core/trunk/ChangeLog (rev 0)
+++ build_system/mdv-youri-core/trunk/ChangeLog 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,2 @@
+2006-04-23 Guillaume Rousse <guillomovitch at zarb.org> 0.9
+ * initial release
Added: build_system/mdv-youri-core/trunk/MANIFEST.SKIP
===================================================================
--- build_system/mdv-youri-core/trunk/MANIFEST.SKIP (rev 0)
+++ build_system/mdv-youri-core/trunk/MANIFEST.SKIP 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,14 @@
+CVS/.*
+\.svn/.*
+^cover_db/
+^blib/
+\.bak$
+\.swp$
+\.tar$
+\.tgz$
+\.tar\.gz$
+\.SKIP$
+~$
+^pm_to_blib$
+^Makefile$
+^Makefile\.old$
Added: build_system/mdv-youri-core/trunk/Makefile.PL
===================================================================
--- build_system/mdv-youri-core/trunk/Makefile.PL (rev 0)
+++ build_system/mdv-youri-core/trunk/Makefile.PL 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,31 @@
+# $Id: Makefile.PL 1724 2006-10-17 13:55:27Z warly $
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'youri-core',
+ VERSION => 0.9,
+ AUTHOR => 'Youri project <youri at zarb.org>',
+ PREREQ_PM => {
+ 'AppConfig' => 0,
+ 'YAML' => 0,
+ 'Pod::Simple::HTMLBatch' => 0,
+ 'Test::Exception' => 0,
+ 'Exception' => 0,
+ 'RPM4' => 0,
+ 'URPM' => 0
+ }
+);
+
+package MY;
+
+sub top_targets {
+ my ($self) = @_;
+ my $top_targets = $self->SUPER::top_targets(@_);
+ $top_targets =~ s/all :: pure_all manifypods/all :: pure_all manifypods htmlifypods/;
+ $top_targets .= <<'EOF';
+htmlifypods : $(TO_INST_PM)
+ if [ ! -d blib/html ]; then mkdir blib/html; fi
+ perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go lib blib/html
+EOF
+ return $top_targets;
+}
Added: build_system/mdv-youri-core/trunk/README
===================================================================
--- build_system/mdv-youri-core/trunk/README (rev 0)
+++ build_system/mdv-youri-core/trunk/README 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,33 @@
+youri-core
+----------
+
+Youri core libraries.
+
+Description
+-----------
+YOURI stands for "Youri Offers an Upload & Repository Infrastucture". It aims
+to build tools making management of a coherent set of packages easier.
+
+This package provides basic components used by other youri programs.
+
+Installation
+------------
+To install, just use:
+perl Makefile.PL
+make
+make test
+
+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.
+
+Authors
+-------
+Guillaume Rousse <guillomovitch at zarb.org>,
+Pascal Terjan <pterjan at zarb.org>
+Damien Krotkine <dams at zarb.org>
+Olivier Thauvin <nanardon at zarb.org>
+Ville Skytt\xE4 <ville.skytta at iki.fi>
Added: build_system/mdv-youri-core/trunk/TODO
===================================================================
--- build_system/mdv-youri-core/trunk/TODO (rev 0)
+++ build_system/mdv-youri-core/trunk/TODO 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,7 @@
+1.0 Goals
+=========
+
+library:
+- API-based bugzilla interface, instead of SQL-based one
+- more generic check-specific options handling in medias (don't use a
+specific attribute for each of them)
Added: build_system/mdv-youri-core/trunk/bin/fillbugzilla
===================================================================
--- build_system/mdv-youri-core/trunk/bin/fillbugzilla (rev 0)
+++ build_system/mdv-youri-core/trunk/bin/fillbugzilla 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+# fillbugzilla
+# copyright (c) 2002 Guillaume Rousse <guillomovitch at zarb.org>
+# $Id: fillbugzilla 1179 2006-08-05 08:30:57Z warly $
+
+use strict;
+use warnings;
+use Getopt::Long;
+use Bugzilla;
+use Mail::Sendmail;
+
+# constants
+my $name = "fillbugzilla";
+my $version = "1.0";
+
+# command-line parameters
+my ($base, $user, $pass, $project, $mode, $help);
+GetOptions(
+ "base=s" => \$base,
+ "user=s" => \$user,
+ "pass=s" => \$pass,
+ "mode=s" => \$mode,
+ "help" => \$help,
+);
+
+# mandatory argument
+die usage() unless ($base && $user && $pass);
+die usage() unless ($mode eq 'package' || $mode eq 'packager');
+
+usage() && exit 0 if $help;
+
+my $bugzilla = Bugzilla->new('localhost', $base, $user, $pass);
+
+if ($mode eq 'packager') {
+ while (my $packager = <>) {
+ chomp $packager;
+ my ($name, $login) = split(/\t/, $packager);
+
+ # random passwd
+ my @chars = (0..9, 'A'..'Z', 'a'..'z', '-', '_', '!', '@', '#', '$', '%', '^', '&', '*');
+ my $password = join('', map { $chars[rand(scalar @chars)] } 1 .. 8);
+
+ # insert into database
+ $bugzilla->add_packager($name, $login, $password);
+
+ # mail user
+ my %mail = (
+ smtp => 'localhost',
+ To => $login,
+ From => 'bugmaster at zarb.org',
+ Subject => 'bugzilla password',
+ 'X-Mailer' => "$name $version",
+ );
+ $mail{Message} .= "login: $login\n";
+ $mail{Message} .= "password: $password\n";
+ sendmail(%mail) or warn $Mail::Sendmail::error;
+ }
+}
+
+if ($mode eq 'package') {
+ while (my $line = <>) {
+ chomp $line;
+ my ($name, $summary, $version, $maintainer) = split(/\t/, $line);
+ $bugzilla->add_package($name, $summary, $version, $maintainer);
+ }
+}
+
+sub usage {
+ print <<EOF;
+$name $version
+
+Usage:
+$name --base <base> --user <user> --pass <pass> --mode <mode> < $file
+
+Options:
+--base <base> bugzilla base name
+--user <user> bugzilla base user
+--pass <pass> bugzilla base password
+--mode <mode> package or packager
+EOF
+}
Property changes on: build_system/mdv-youri-core/trunk/bin/fillbugzilla
___________________________________________________________________
Added: svn:executable
+ *
Added: build_system/mdv-youri-core/trunk/cgi/maintainers.cgi
===================================================================
--- build_system/mdv-youri-core/trunk/cgi/maintainers.cgi (rev 0)
+++ build_system/mdv-youri-core/trunk/cgi/maintainers.cgi 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,65 @@
+#!/usr/bin/perl
+# $Id: maintainers.cgi 1179 2006-08-05 08:30:57Z warly $
+
+=head1 NAME
+
+maintainers.cgi - youri CGI interface to maintainers list
+
+=head1 VERSION
+
+Version 1.0
+
+=head1 DESCRIPTION
+
+This script allows to get package maintainers list through CGI interface.
+
+=head1 SYNOPSIS
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2004-2005, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Guillaume Rousse <guillomovitch at zarb.org>,
+
+=cut
+
+use Youri::Bugzilla;
+use CGI;
+use AppConfig qw/:argcount :expand/;
+use strict;
+use warnings;
+
+my $config = AppConfig->new(
+ {
+ GLOBAL => {
+ DEFAULT => undef,
+ EXPAND => EXPAND_ALL,
+ ARGCOUNT => ARGCOUNT_ONE,
+ }
+ },
+ host => { ARGCOUNT => ARGCOUNT_ONE },
+ base => { ARGCOUNT => ARGCOUNT_ONE },
+ user => { ARGCOUNT => ARGCOUNT_ONE },
+ pass => { ARGCOUNT => ARGCOUNT_ONE },
+);
+
+my $home = (getpwnam($ENV{PROJECT}))[7];
+foreach my $file ("/etc/youri/maintainers.conf", "$home/.youri/maintainers.conf") {
+ $config->file($file) if -f $file && -r $file;
+}
+
+my $bugzilla = Bugzilla->new(
+ $config->host(),
+ $config->base(),
+ $config->user(),
+ $config->pass(),
+);
+
+my $cgi = CGI->new();
+print $cgi->header(-type=>'text/plain');
+
+$bugzilla->browse_packages(sub { print "$_[0]\t$_[2]\n"; });
Property changes on: build_system/mdv-youri-core/trunk/cgi/maintainers.cgi
___________________________________________________________________
Added: svn:executable
+ *
Added: build_system/mdv-youri-core/trunk/etc/bash_completion.d/youri
===================================================================
--- build_system/mdv-youri-core/trunk/etc/bash_completion.d/youri (rev 0)
+++ build_system/mdv-youri-core/trunk/etc/bash_completion.d/youri 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,141 @@
+# youri tools completion
+# $Id$
+
+_youri-check()
+{
+
+ local cur prev config i mode
+
+ COMPREPLY=()
+ cur=${COMP_WORDS[COMP_CWORD]}
+ prev=${COMP_WORDS[COMP_CWORD-1]}
+
+ case "$prev" in
+ --config)
+ _filedir
+ return 0
+ ;;
+ --skip-plugin)
+ _find_config check.conf
+ if [ -n "$config" ]; then
+ # try to guess mode
+ for (( i=1; i < COMP_CWORD; i++ )); do
+ if [[ "${COMP_WORDS[i]}" != -* ]]; then
+ mode=${COMP_WORDS[i]}
+ break
+ fi
+ done
+
+ if [ -n $mode ]; then
+ COMPREPLY=( $( awk -F= '/^'$mode's/ {print $2}' $config \
+ | grep "^$cur" ) )
+ fi
+ fi
+ return 0
+ ;;
+ --skip-media)
+ _find_config check.conf
+ if [ -n "$config" ]; then
+ COMPREPLY=( $( awk -F= '/^medias/ {print $2}' $config \
+ | grep "^$cur" ) )
+ fi
+ return 0
+ ;;
+ esac
+
+ if [[ "$cur" == -* ]]; then
+ COMPREPLY=( $( compgen -W '--config --skip-plugin --skip-media -h \
+ --help -t --test -v --verbose' -- $cur ) )
+ else
+ _count_args
+ case $args in
+ 1)
+ COMPREPLY=( $( compgen -W 'input output' -- $cur ) )
+ ;;
+ esac
+ fi
+
+}
+complete -F _youri-check youri-check
+
+_youri-upload()
+{
+
+ local cur prev config
+
+ COMPREPLY=()
+ cur=${COMP_WORDS[COMP_CWORD]}
+ prev=${COMP_WORDS[COMP_CWORD-1]}
+
+ case "$prev" in
+ --config)
+ _filedir
+ return 0
+ ;;
+ --skip-check)
+ _find_config upload.conf
+ if [ -n "$config" ]; then
+ COMPREPLY=( $( awk -F= '/^checks/ {print $2}' $config \
+ | grep "^$cur" ) )
+ fi
+ return 0
+ ;;
+ --skip-action)
+ _find_config upload.conf
+ if [ -n "$config" ]; then
+ COMPREPLY=( $( awk -F= '/^actions/ {print $2}' $config \
+ | grep "^$cur" ) )
+ fi
+ return 0
+ ;;
+ esac
+
+ if [[ "$cur" == -* ]]; then
+ COMPREPLY=( $( compgen -W '--config --skip-check --skip-action \
+ --define -h --help -t --test -v --verbose' -- $cur ) )
+ else
+ _count_args
+ case $args in
+ 1)
+ _find_config upload.conf
+ if [ -n "$config" ]; then
+ COMPREPLY=( $( awk -F= '/^targets/ {print $2}' $config \
+ | grep "^$cur" ) )
+ fi
+ ;;
+ *)
+ _filedir
+ ;;
+ esac
+ fi
+
+}
+complete -F _youri-upload youri-upload
+
+_find_config()
+{
+ local name i
+
+ name=$1
+
+ for (( i=1; i < COMP_CWORD; i++ )); do
+ if [[ "${COMP_WORDS[i]}" == --config ]]; then
+ config=${COMP_WORDS[i+1]}
+ break
+ fi
+ done
+ if [ -f "$config" ]; then
+ return 0
+ fi
+
+ if [ -f "$HOME/.youri/$name" ]; then
+ config=$HOME/.youri/$name
+ return 0
+ fi
+
+ if [ -f "/etc/youri/$name" ]; then
+ config=/etc/youri/$name
+ return 0
+ fi
+
+}
Added: build_system/mdv-youri-core/trunk/etc/check.conf
===================================================================
--- build_system/mdv-youri-core/trunk/etc/check.conf (rev 0)
+++ build_system/mdv-youri-core/trunk/etc/check.conf 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,300 @@
+# youri-check sample configuration file
+# $Id: check.conf 1179 2006-08-05 08:30:57Z warly $
+
+# resolver declaration
+resolver = cgi
+
+# preferences declaration
+preferences = file_pref
+
+# resultset declaration
+resultset = dbi
+
+# input plugins declaration
+inputs = rpmlint \
+ age \
+ updates \
+ build \
+ conflicts \
+ dependencies \
+ missing \
+ orphans
+
+# output plugins declaration
+outputs = file mail
+
+# medias declaration
+medias = main.i586 \
+ main.x86_64 \
+ main.sources \
+ contrib.i586 \
+ contrib.x86_64 \
+ contrib.sources \
+ free \
+ non-free \
+ free.sources \
+ non-free.sources
+
+# helper variables
+mirror = ftp://ftp.free.fr/pub/Distributions_Linux/Mandrakelinux/devel/cooker
+mirror_i586 = $mirror/i586/media
+mirror_x86_64 = $mirror/x86_64/media
+
+# resolver definition
+[cgi]
+class = Youri::Check::Maintainer::Resolver::CGI
+url = http://plf.zarb.org/cgi-bin/maintainers.cgi
+
+# preferences definition
+[file_pref]
+class = Youri::Check::Maintainer::Preferences::File
+
+# resultset definition
+[dbi]
+class = Youri::Check::Resultset::DBI
+driver = mysql
+host = localhost
+base = plf_youri
+user = plf
+pass = s3kr3t
+
+# checks definitions
+[updates]
+class = Youri::Check::Input::Updates
+aliases = <<EOF
+--- #YAML:1.0
+libfame0.8: ~
+EOF
+sources = <<EOF
+--- #YAML:1.0
+debian:
+ class: Youri::Check::Input::Updates::Source::Debian
+ aliases:
+ fuse-emulator: ~
+cpan:
+ class: Youri::Check::Input::Updates::Source::CPAN
+fedora:
+ class: Youri::Check::Input::Updates::Source::Fedora
+gentoo:
+ class: Youri::Check::Input::Updates::Source::Gentoo
+freshmeat:
+ class: Youri::Check::Input::Updates::Source::Freshmeat
+netbsd:
+ class: Youri::Check::Input::Updates::Source::NetBSD
+raa:
+ class: Youri::Check::Input::Updates::Source::RAA
+sourceforge:
+ class: Youri::Check::Input::Updates::Source::Sourceforge
+ aliases:
+ openquicktime: ~
+ klibido: ~
+EOF
+
+[rpmlint]
+class = Youri::Check::Input::Rpmlint
+
+[age]
+class = Youri::Check::Input::Age
+max_age = 12 months
+pattern = %m months
+
+[dependencies]
+class = Youri::Check::Input::Dependencies
+
+[conflicts]
+class = Youri::Check::Input::Conflicts
+
+[build]
+class = Youri::Check::Input::Build
+sources = <<EOF
+--- #YAML:1.0
+stefan:
+ class: Youri::Check::Input::Build::Source::LBD
+ url: http://eijk.homelinux.org/build/
+ medias:
+ - cooker_plf-free
+ - cooker_plf-non-free
+ archs:
+ - i586
+EOF
+
+[missing]
+class = Youri::Check::Input::Missing
+
+[orphans]
+class = Youri::Check::Input::Orphans
+
+# reports definitions
+[file]
+class = Youri::Check::Output::File
+to = ${HOME}/www/qa
+global = 1
+individual = 1
+formats = <<EOF
+--- #YAML:1.0
+html:
+ class: Youri::Check::Output::File::Format::HTML
+text:
+ class: Youri::Check::Output::File::Format::Text
+rss:
+ class: Youri::Check::Output::File::Format::RSS
+EOF
+
+[mail]
+class = Youri::Check::Output::Mail
+mta = /usr/sbin/sendmail
+to = plf-admin at zarb.org
+from = plf at zarb.org
+reply_to = plf-admin at zarb.org
+formats = <<EOF
+--- #YAML:1.0
+text:
+ class: Youri::Check::Output::Mail::Format::Text
+EOF
+
+# media definitions
+[main.i586]
+class = Youri::Media::URPM
+name = main
+type = binary
+path = $mirror_i586/main
+hdlist = $mirror_i586/media_info/hdlist_main.cz
+skip_inputs = <<EOF
+--- #YAML:1.0
+- all
+EOF
+
+[main.x86_64]
+class = Youri::Media::URPM
+name = main
+type = binary
+path = $mirror_x86_64/main
+hdlist = $mirror_x86_64/media_info/hdlist_main.cz
+skip_inputs = <<EOF
+--- #YAML:1.0
+- all
+EOF
+
+[main.sources]
+class = Youri::Media::URPM
+name = main
+type = source
+path = $mirror_i586/main
+hdlist = $mirror_i586/media_info/hdlist_main.src.cz
+skip_inputs = <<EOF
+--- #YAML:1.0
+- all
+EOF
+
+[contrib.i586]
+class = Youri::Media::URPM
+name = contrib
+type = binary
+path = $mirror_i586/contrib
+hdlist = $mirror_i586/media_info/hdlist_contrib.cz
+skip_inputs = <<EOF
+--- #YAML:1.0
+- all
+EOF
+
+[contrib.x86_64]
+class = Youri::Media::URPM
+name = contrib
+type = binary
+path = $mirror_x86_64/contrib
+hdlist = $mirror_x86_64/media_info/hdlist_contrib.cz
+skip_inputs = <<EOF
+--- #YAML:1.0
+- all
+EOF
+
+[contrib.sources]
+class = Youri::Media::URPM
+name = contrib
+type = source
+path = $mirror_i586/contrib
+hdlist = $mirror_i586/media_info/hdlist_contrib.src.cz
+skip_inputs = <<EOF
+--- #YAML:1.0
+- all
+EOF
+
+[free]
+class = Youri::Media::URPM
+name = free
+type = binary
+path = ${HOME}/ftp/mandrake/free/cooker/i586
+hdlist = ${HOME}/ftp/mandrake/free/cooker/i586/hdlist.cz
+rpmlint_config = ${HOME}/etc/rpmlint-free.conf
+allow_deps = <<EOF
+--- #YAML:1.0
+- main.i586
+- main.x86_64
+- contrib.i586
+- contrib.x86_64
+- free
+EOF
+allow_srcs = <<EOF
+--- #YAML:1.0
+- free.sources
+- main.sources
+- contrib.sources
+EOF
+skip_archs = <<EOF
+--- #YAML:1.0
+- ppc
+EOF
+
+[free.sources]
+class = Youri::Media::URPM
+name = free
+type = source
+path = ${HOME}/ftp/mandrake/free/src
+hdlist = ${HOME}/ftp/mandrake/free/src/hdlist.cz
+rpmlint_config = ${HOME}/etc/rpmlint-free.conf
+allow_deps = <<EOF
+--- #YAML:1.0
+- main.i586
+- contrib.i586
+- free
+EOF
+
+[non-free]
+class = Youri::Media::URPM
+name = non-free
+type = binary
+path = ${HOME}/ftp/mandrake/non-free/cooker/i586
+hdlist = ${HOME}/ftp/mandrake/non-free/cooker/i586/hdlist.cz
+rpmlint_config = ${HOME}/etc/rpmlint-non-free.conf
+allow_deps = <<EOF
+--- #YAML:1.0
+- main.i586
+- main.x86_64
+- contrib.i586
+- contrib.x86_64
+- free
+- non-free
+EOF
+allow_srcs = <<EOF
+--- #YAML:1.0
+- non-free.sources
+EOF
+skip_archs = <<EOF
+--- #YAML:1.0
+- ppc
+EOF
+
+[non-free.sources]
+class = Youri::Media::URPM
+name = non-free
+type = source
+path = ${HOME}/ftp/mandrake/non-free/src
+hdlist = ${HOME}/ftp/mandrake/non-free/src/hdlist.cz
+rpmlint_config = ${HOME}/etc/rpmlint-non-free.conf
+allow_deps = <<EOF
+--- #YAML:1.0
+- main.i586
+- contrib.i586
+- free
+- non-free
+EOF
Added: build_system/mdv-youri-core/trunk/etc/upload.conf
===================================================================
--- build_system/mdv-youri-core/trunk/etc/upload.conf (rev 0)
+++ build_system/mdv-youri-core/trunk/etc/upload.conf 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,139 @@
+# youri-upload sample configuration file
+# $Id: upload.conf 1179 2006-08-05 08:30:57Z warly $
+
+# repository declaration
+repository = plf
+
+# targets declaration
+targets = cooker 2006.0
+
+# repository definition
+[plf]
+class = Youri::Repository::PLF
+install_root = ${HOME}/ftp/mandriva
+version_root = ${HOME}/cvs
+archive_root = ${HOME}/backup/mandriva
+noarch = i586
+
+# targets definition
+[cooker]
+checks = <<EOF
+--- #YAML:1.0
+- tag
+- recency
+- history
+EOF
+actions = <<EOF
+--- #YAML:1.0
+- sign
+- install
+- link
+- archive
+- clean
+- bugzilla
+- cvs
+- mail
+- rss
+EOF
+
+[2006.0]
+checks = <<EOF
+--- #YAML:1.0
+- type
+- tag
+- recency
+- history
+- precedence
+EOF
+actions = <<EOF
+--- #YAML:1.0
+- sign
+- install
+- link
+- archive
+- clean
+EOF
+
+# checks definition
+[tag]
+class = Youri::Upload::Check::Tag
+tags = <<EOF
+--- #YAML:1.0
+release: 'plf$'
+packager: '<\w+ at zarb\.org>$'
+distribution: '^Mandriva Linux$'
+vendor: '^Penguin Liberation Front$'
+EOF
+
+[recency]
+class = Youri::Upload::Check::Recency
+
+[history]
+class = Youri::Upload::Check::History
+
+[precedence]
+class = Youri::Upload::Check::Precedence
+target = cooker
+
+[type]
+class = Youri::Upload::Check::Type
+type = binary
+
+# actions definitions
+[sign]
+class = Youri::Upload::Action::Sign
+name = plf at zarb.org
+path = ${HOME}/.gnupg
+passphrase = s3kr3t
+
+[install]
+class = Youri::Upload::Action::Install
+
+[link]
+class = Youri::Upload::Action::Link
+
+[archive]
+class = Youri::Upload::Action::Archive
+
+[clean]
+class = Youri::Upload::Action::Clean
+
+[mail]
+class = Youri::Upload::Action::Mail
+mta = /usr/sbin/sendmail
+to = plf-announce at zarb.org
+reply_to = plf-discuss at zarb.org
+from = plf at zarb.org
+prefix = RPM
+cc = <<EOF
+--- #YAML:1.0
+hot-base: david at dindinx.org bellamy at neverland.net
+dcgui: mathen at ketelhot.de
+dclib: mathen at ketelhot.de
+Video-DVDRip: dvdrip-users at exit1.org
+hackVideo-DVDRip: dvdrip-users at exit1.org
+goosnes: tak at bard.sytes.net
+avidemux: fixounet at free.fr
+vobcopy: robos at muon.de
+drip: drip-devel at lists.sourceforge.net
+libdscaler: vektor at dumbterm.net
+xawdecode: pingus77 at ifrance.com
+EOF
+
+[rss]
+class = Youri::Upload::Action::RSS
+file = ${HOME}/www/changelog.rss
+title = PLF packages updates
+link = http://plf.zarb.org/
+description = ChangeLog for PLF packages
+
+[cvs]
+class = Youri::Upload::Action::CVS
+
+[bugzilla]
+class = Youri::Upload::Action::Bugzilla
+host = localhost
+base = plf_bugs
+user = plf
+pass = s3kr3t
+contact = plf at zarb.org
Added: build_system/mdv-youri-core/trunk/lib/Youri/Bugzilla.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Bugzilla.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Bugzilla.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,482 @@
+# $Id: Bugzilla.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Bugzilla;
+
+=head1 NAME
+
+Youri::Bugzilla - Youri Bugzilla interface
+
+=head1 SYNOPSIS
+
+ use Youri::Bugzilla;
+
+ my $bugzilla = Youri::Bugzilla->new($host, $base, $user, $pass);
+
+ print $bugzilla->get_maintainer('foobar');
+
+=head1 DESCRIPTION
+
+This module implement a database-level Bugzilla interface for managing packages.
+
+The legacy Bugzilla database model is mapped this way:
+
+=over
+
+=item *
+
+a maintainer is a user
+
+=item *
+
+a package is a product
+
+=item *
+
+each package has two pseudo components "program" and "package", owned by the package maintainer
+
+=back
+
+=cut
+
+use DBI;
+use Carp;
+use strict;
+use warnings;
+
+my %queries = (
+ get_package_id => 'SELECT id FROM products WHERE name = ?',
+ get_maintainer_id => 'SELECT userid FROM profiles WHERE login_name = ?',
+ get_versions => 'SELECT value FROM versions WHERE product_id = ?',
+ get_components => 'SELECT name FROM components WHERE product_id = ?',
+ add_package => 'INSERT INTO products (name, description) VALUES (?, ?)',
+ add_maintainer => 'INSERT INTO profiles (login_name, cryptpassword, realname, emailflags, refreshed_when) VALUES (?, ENCRYPT(?), ?, ?, SYSDATE())',
+ add_component => 'INSERT INTO components (product_id, name, description,initialowner, initialqacontact) VALUES (?, ?, ?, ?, ?)',
+ add_version => 'INSERT INTO versions (product_id, value) VALUES (?, ?)',
+ del_package => 'DELETE FROM products WHERE product = ?',
+ del_maintainer => 'DELETE FROM profiles WHERE login_name = ?',
+ del_components => 'DELETE FROM components WHERE program = ?',
+ del_versions => 'DELETE FROM versions WHERE program = ?',
+ reset_password => 'UPDATE profiles SET cryptpassword = ENCRYPT(?) WHERE login_name = ?',
+ browse_packages => <<EOF,
+SELECT products.name, max(versions.value), login_name
+FROM products, versions, profiles, components
+WHERE versions.product_id = products.id
+ AND components.product_id = products.id
+ AND profiles.userid = components.initialowner
+ AND components.name = 'package'
+GROUP BY name
+EOF
+ get_maintainer => <<EOF
+SELECT login_name
+FROM profiles, components, products
+WHERE profiles.userid = components.initialowner
+ AND components.name = 'package'
+ AND components.product_id = products.id
+ AND products.name = ?
+EOF
+);
+
+my @default_flags = qw/
+ ExcludeSelf
+ FlagRequestee
+ FlagRequester
+ emailOwnerRemoveme
+ emailOwnerComments
+ emailOwnerAttachments
+ emailOwnerStatus
+ emailOwnerResolved
+ emailOwnerKeywords
+ emailOwnerCC
+ emailOwnerOther
+ emailOwnerUnconfirmed
+ emailReporterRemoveme
+ emailReporterComments
+ emailReporterAttachments
+ emailReporterStatus
+ emailReporterResolved
+ emailReporterKeywords
+ emailReporterCC
+ emailReporterOther
+ emailReporterUnconfirmed
+ emailQAcontactRemoveme
+ emailQAcontactComments
+ emailQAcontactAttachments
+ emailQAcontactStatus
+ emailQAcontactResolved
+ emailQAcontactKeywords
+ emailQAcontactCC
+ emailQAcontactOther
+ emailQAcontactUnconfirmed
+ emailCClistRemoveme
+ emailCClistComments
+ emailCClistAttachments
+ emailCClistStatus
+ emailCClistResolved
+ emailCClistKeywords
+ emailCClistCC
+ emailCClistOther
+ emailCClistUnconfirmed
+ emailVoterRemoveme
+ emailVoterComments
+ emailVoterAttachments
+ emailVoterStatus
+ emailVoterResolved
+ emailVoterKeywords
+ emailVoterCC
+ emailVoterOther
+ emailVoterUnconfirmed
+/;
+
+my $default_flags = join('~', map { "$_~on" } @default_flags);
+
+=head1 CLASS METHODS
+
+Except stated otherwise, maintainers are specified by their login, and packages
+are specified by their name.
+
+=head2 new($host, $base, $user, $password)
+
+Creates a new L<Youri::Bugzilla> object, wrapping bugzilla database I<$base>
+hosted on I<$host>, and accessed by user I<$user> with password I<$password>.
+
+=cut
+
+sub new {
+ my ($class, $host, $base, $user, $pass) = @_;
+
+ my $dbh = DBI->connect("DBI:mysql:database=$base;host=$host", $user, $pass) or croak "Unable to connect: $DBI::errstr";
+
+ my $self = bless {
+ _dbh => $dbh
+ }, $class;
+
+ return $self;
+}
+
+=head1 INSTANCE METHODS
+
+=head2 has_package($package)
+
+Return true if bugzilla contains given package.
+
+=cut
+
+sub has_package {
+ my ($self, $package) = @_;
+ return $self->_get_package_id($package);
+}
+
+=head2 has_maintainer($maintainer)
+
+Return true if bugzilla contains given maintainer.
+
+=cut
+
+sub has_maintainer {
+ my ($self, $maintainer) = @_;
+ return $self->_get_maintainer_id($maintainer);
+}
+
+=head2 get_maintainer($package)
+
+Return maintainer of given package.
+
+=cut
+
+sub get_maintainer {
+ my ($self, $package) = @_;
+ return $self->_get_single('get_maintainer', $package);
+}
+
+=head2 get_versions($package)
+
+Return versions from given package.
+
+=cut
+
+sub get_versions {
+ my ($self, $package) = @_;
+ return $self->_get_multiple(
+ 'get_versions',
+ $self->_get_package_id($package)
+ );
+}
+
+=head2 get_components($package)
+
+Return components from given package.
+
+=cut
+
+sub get_components {
+ my ($self, $package) = @_;
+ return $self->_get_multiple(
+ 'get_components',
+ $self->_get_package_id($package)
+ );
+}
+
+=head2 get_packages()
+
+Return all packages from the database.
+
+=cut
+
+sub get_packages {
+ my ($self) = @_;
+ return $self->_get_multiple('get_packages');
+}
+
+sub _get_package_id {
+ my ($self, $package) = @_;
+ return $self->_get_single('get_package_id', $package);
+}
+
+sub _get_maintainer_id {
+ my ($self, $maintainer) = @_;
+ return $self->_get_single('get_maintainer_id', $maintainer);
+}
+
+sub _get_single {
+ my ($self, $type, $value) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{$type};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{$type});
+ $self->{_queries}->{$type} = $query;
+ }
+
+ $query->execute($value);
+
+ my @row = $query->fetchrow_array();
+ return @row ? $row[0]: undef;
+}
+
+sub _get_multiple {
+ my ($self, $type, $value) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{$type};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{$type});
+ $self->{_queries}->{$type} = $query;
+ }
+
+ $query->execute($value);
+
+ my @results;
+ while (my @row = $query->fetchrow_array()) {
+ push @results, $row[0];
+ }
+ return @results;
+}
+
+=head2 add_package($name, $summary, $version, $maintainer, $contact)
+
+Adds a new package in the database, with given name, summary, version,
+maintainer and initial QA contact.
+
+=cut
+
+sub add_package {
+ my ($self, $name, $summary, $version, $maintainer, $contact) = @_;
+ return unless ref $self;
+
+ my $maintainer_id = $self->_get_maintainer_id($maintainer);
+ unless ($maintainer_id) {
+ carp "Unknown maintainer $maintainer, aborting";
+ return;
+ }
+
+ my $contact_id = $self->_get_maintainer_id($contact);
+ unless ($contact_id) {
+ carp "Unknown QA contact $contact, aborting";
+ return;
+ }
+
+ my $query = $self->{_queries}->{add_package};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{add_package});
+ $self->{_queries}->{add_package} = $query;
+ }
+
+ $query->execute($name, $summary);
+
+ my $package_id = $self->_get_package_id($name);
+
+ $self->_add_version($package_id, $version);
+ $self->_add_component(
+ $package_id,
+ 'package',
+ 'problem related to the package',
+ $maintainer_id,
+ $contact_id
+ );
+ $self->_add_component(
+ $package_id,
+ 'program',
+ 'problem related to the program',
+ $maintainer_id,
+ $contact_id
+ );
+}
+
+=head2 add_version($package, $version)
+
+Adds a new version to given package.
+
+=cut
+
+sub add_version {
+ my ($self, $package, $version) = @_;
+ return unless ref $self;
+
+ my $package_id = $self->_get_package_id($package);
+ $self->_add_version($package_id, $version);
+}
+
+sub _add_version {
+ my ($self, $package_id, $version) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{add_version};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{add_version});
+ $self->{_queries}->{add_version} = $query;
+ }
+
+ $query->execute($package_id, $version);
+}
+
+
+=head2 add_maintainer($name, $login, $password)
+
+Adds a new maintainer in the database, with given name, login and password.
+
+=cut
+
+sub add_maintainer {
+ my ($self, $name, $login, $pass) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{add_maintainer};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{add_maintainer});
+ $self->{_queries}->{add_maintainer} = $query;
+ }
+
+ $query->execute($login, $pass, $name, $default_flags);
+}
+
+sub _add_component {
+ my ($self, $package_id, $name, $description, $maintainer_id, $contact_id) = @_;
+
+ my $query = $self->{_queries}->{add_component};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{add_component});
+ $self->{_queries}->{add_component} = $query;
+ }
+
+ $query->execute($package_id, $name, $description, $maintainer_id, $contact_id);
+}
+
+=head2 del_package($package)
+
+Delete given package from database.
+
+=cut
+
+sub del_package {
+ my ($self, $package) = @_;
+ $self->_delete('del_package', $package);
+ $self->_delete('del_versions', $package);
+ $self->_delete('del_components', $package);
+}
+
+=head2 del_maintainer($maintainer)
+
+Delete given maintainer from database.
+
+=cut
+
+sub del_maintainer {
+ my ($self, $maintainer) = @_;
+ $self->_delete('del_maintainer', $maintainer);
+}
+
+sub _delete {
+ my ($self, $type, $value) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{$type};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{$type});
+ $self->{_queries}->{$type} = $query;
+ }
+
+ $query->execute($value);
+}
+
+=head2 reset_password(I<$maintainer>, I<$password>)
+
+Reset password of a maintainer to given password.
+
+=cut
+
+sub reset_password {
+ my ($self, $login, $pass) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{reset_password};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{reset_password});
+ $self->{_queries}->{reset_password} = $query;
+ }
+
+ $query->execute($pass, $login);
+}
+
+=head2 browse_packages($callback)
+
+Browse all packages from bugzilla, and execute given callback with name and
+maintainer as argument for each of them.
+
+=cut
+
+sub browse_packages {
+ my ($self, $callback) = @_;
+ return unless ref $self;
+
+ my $query = $self->{_queries}->{browse_packages};
+ unless ($query) {
+ $query = $self->{_dbh}->prepare($queries{browse_packages});
+ $self->{_queries}->{browse_packages} = $query;
+ }
+
+ $query->execute();
+
+ while (my @row = $query->fetchrow_array()) {
+ $callback->(@row);
+ }
+}
+
+# close database connection
+sub DESTROY {
+ my ($self) = @_;
+
+ foreach my $query (values %{$self->{_queries}}) {
+ $query->finish();
+ }
+
+ $self->{_dbh}->disconnect();
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Age.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Age.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Age.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,110 @@
+# $Id: Age.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Age;
+
+=head1 NAME
+
+Youri::Check::Input::Age - Check maximum age
+
+=head1 DESCRIPTION
+
+This plugin checks packages age, and report the ones exceeding maximum limit.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use DateTime;
+use DateTime::Format::Duration;
+use base 'Youri::Check::Input';
+
+sub columns {
+ return qw/
+ arch
+ buildtime
+ /;
+}
+
+sub links {
+ return qw//;
+}
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Age object.
+
+Specific parameters:
+
+=over
+
+=item max_age $age
+
+Maximum age allowed (default: 1 year)
+
+=item pattern $pattern
+
+Pattern used to describe age (default: %Y year)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ max_age => '1 year',
+ pattern => '%Y year',
+ @_
+ );
+
+ $self->{_format} = DateTime::Format::Duration->new(
+ pattern => $options{pattern}
+ );
+
+ $self->{_now} = DateTime->from_epoch(
+ epoch => time()
+ );
+
+ $self->{_max_age} = $options{max_age};
+}
+
+sub run {
+ my ($self, $media, $resultset) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $max_age_string = $media->max_age() ?
+ $media->max_age() :
+ $self->{_max_age};
+
+ my $max_age = $self->{_format}->parse_duration($max_age_string);
+
+ my $check = sub {
+ my ($package) = @_;
+
+ my $buildtime = DateTime->from_epoch(
+ epoch => $package->get_age()
+ );
+
+ my $age = $self->{_now}->subtract_datetime($buildtime);
+
+ if (DateTime::Duration->compare($age, $max_age) > 0) {
+ my $date = $buildtime->strftime("%a %d %b %G");
+
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $package->get_arch(),
+ buildtime => $date
+ });
+ }
+ };
+ $media->traverse_headers($check);
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/Iurt.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/Iurt.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/Iurt.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/LBD.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/LBD.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source/LBD.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,135 @@
+# $Id: LBD.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Build::Source::LBD;
+
+=head1 NAME
+
+Youri::Check::Input::Build::Source::LBD - LBD build log source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Build> collects build logs
+available from a LBD build bot.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use LWP::UserAgent;
+use HTML::TokeParser;
+use base 'Youri::Check::Input::Build::Source';
+
+my @status = qw/
+ OK
+ arch_excl
+ broken
+ cannot_be_installed
+ debug
+ dependency
+ file_not_found
+ multiarch
+ problem
+ unpackaged_files
+/;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Build::LBD object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL of logs for this LBD instance (default: http://eijk.homelinux.org/build)
+
+=item medias $medias
+
+List of medias monitored by this LBD instance
+
+=item archs $archs
+
+List of architectures monitored by this LBD instance
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://eijk.homelinux.org/build',
+ medias => undef,
+ archs => undef,
+ @_
+ );
+
+ my $agent = LWP::UserAgent->new();
+
+ # try to connect to base URL directly, and abort if not available
+ my $response = $agent->head($options{url});
+ die "Unavailable URL $options{url}: " . $response->status_line()
+ unless $response->is_success();
+
+ my $pattern = '^(\S+)-([^-]+)-([^-]+)(?:\.gz)?$';
+
+ foreach my $arch (@{$options{archs}}) {
+ foreach my $media (@{$options{medias}}) {
+ my $url_base = "$options{url}/$arch/$media/BO";
+ foreach my $status (@status) {
+ my $url = "$url_base/$status/";
+ print "Fetching URL $url: " if $self->{_verbose} > 1;
+ my $response = $agent->get($url);
+ print $response->status_line() . "\n" if $self->{_verbose} > 1;
+ if ($response->is_success()) {
+ my $parser = HTML::TokeParser->new(\$response->content());
+ while (my $token = $parser->get_tag('a')) {
+ my $href = $token->[1]->{href};
+ next unless $href =~ /$pattern/o;
+ my $name = $1;
+ my $version = $2;
+ my $release = $3;
+ my $result;
+ $result->{status} = $status;
+ $result->{url} = $url . '/' . $href;
+ $self->{_results}->{$name}->{$version}->{$release}->{$arch} = $result;
+ }
+ }
+ }
+ }
+ }
+}
+
+sub fails {
+ my ($self, $name, $version, $release, $arch) = @_;
+
+ my $status =
+ $self->{_results}->{$name}->{$version}->{$release}->{$arch}->{status};
+
+ return $status && $status ne 'OK' && $status ne 'arch_excl';
+}
+
+sub status {
+ my ($self, $name, $version, $release, $arch) = @_;
+ return
+ $self->{_results}->{$name}->{$version}->{$release}->{$arch}->{status};
+}
+
+sub url {
+ my ($self, $name, $version, $release, $arch) = @_;
+ return
+ $self->{_results}->{$name}->{$version}->{$release}->{$arch}->{url};
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build/Source.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,109 @@
+# $Id: Source.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Build::Source;
+
+=head1 NAME
+
+Youri::Check::Input::Build::Source - Abstract build log source
+
+=head1 DESCRIPTION
+
+This abstract class defines the updates source interface for
+L<Youri::Check::Input::Build>.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Build object.
+
+No generic parameters (subclasses may define additional ones).
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ id => '', # object id
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ @_
+ );
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+=head2 get_id()
+
+Returns source identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 fails($name, $version, $release, $arch)
+
+Returns true if build fails for package with given name, version and release on
+given architecture.
+
+=head2 status($name, $version, $release, $arch)
+
+Returns exact build status for package with given name, version and release on
+given architecture. It has to be called after fails().
+
+=head2 url($name, $version, $release, $arch)
+
+Returns URL of information source for package with given name, version and
+release on given architecture. It has to be called after fails().
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item fails
+
+=item status
+
+=item url
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Build.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,128 @@
+# $Id: Build.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Build;
+
+=head1 NAME
+
+Youri::Check::Input::Build - Check build outputs
+
+=head1 DESCRIPTION
+
+This plugin checks build outputs of packages, and report failures. Additional
+source plugins handle specific sources.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Utils;
+use base 'Youri::Check::Input';
+
+sub columns {
+ return qw/
+ arch
+ bot
+ status
+ /;
+}
+
+sub links {
+ return qw/
+ status url
+ /;
+}
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Build object.
+
+Specific parameters:
+
+=over
+
+=item sources $sources
+
+Hash of source plugins definitions
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ sources => undef,
+ @_
+ );
+
+ croak "No source defined" unless $options{sources};
+ croak "sources should be an hashref" unless ref $options{sources} eq 'HASH';
+
+ foreach my $id (keys %{$options{sources}}) {
+ print "Creating source $id\n" if $options{verbose};
+ eval {
+ push(
+ @{$self->{_sources}},
+ create_instance(
+ 'Youri::Check::Input::Build::Source',
+ id => $id,
+ test => $options{test},
+ verbose => $options{verbose},
+ %{$options{sources}->{$id}}
+ )
+ );
+ # register monitored archs
+ $self->{_archs}->{$_}->{$id} = 1
+ foreach @{$options{sources}->{$id}->{archs}};
+ };
+ print STDERR "Failed to create source $id: $@\n" if $@;
+ }
+
+ croak "no sources created" unless @{$self->{_sources}};
+}
+
+sub run {
+ my ($self, $media, $resultset) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # this is a source media check only
+ return unless $media->get_type() eq 'source';
+
+ my $callback = sub {
+ my ($package) = @_;
+
+ my $name = $package->get_name();
+ my $version = $package->get_version();
+ my $release = $package->get_release();
+
+ foreach my $source (@{$self->{_sources}}) {
+ my $id = $source->get_id();
+ foreach my $arch (keys %{$self->{_archs}}) {
+ next unless $self->{_archs}->{$arch}->{$id};
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ bot => $id,
+ status => $source->status($name, $version, $release, $arch),
+ url => $source->url($name, $version, $release, $arch),
+ }) if $source->fails(
+ $name,
+ $version,
+ $release,
+ $arch,
+ );
+ }
+ }
+ };
+
+ $media->traverse_headers($callback);
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Conflicts.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Conflicts.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Conflicts.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,231 @@
+# $Id: Conflicts.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Conflicts;
+
+=head1 NAME
+
+Youri::Check::Input::Conflicts - Check file conflicts
+
+=head1 DESCRIPTION
+
+This plugin checks packages files, and report conflict and duplications.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use constant;
+use Youri::Package;
+use base 'Youri::Check::Input';
+
+use constant TYPE_MASK => 0170000;
+use constant TYPE_DIR => 0040000;
+
+use constant PACKAGE => 0;
+use constant MODE => 1;
+use constant MD5SUM => 2;
+
+my $compatibility = {
+ x86_64 => 'i586',
+ i586 => 'x86_64',
+ sparc64 => 'sparc',
+ sparc => 'sparc64',
+ ppc64 => 'ppc',
+ ppc => 'ppc64'
+};
+
+sub columns {
+ return qw/
+ arch
+ file
+ error
+ level
+ /;
+}
+
+sub links {
+ return qw//;
+}
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Conflicts object.
+
+No specific parameters.
+
+=cut
+
+sub prepare {
+ my ($self, @medias) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $index = sub {
+ my ($package) = @_;
+
+ # index files
+ foreach my $file ($package->get_files()) {
+ push(
+ @{$self->{_files}->{$file->[Youri::Package::FILE_NAME]}},
+ [ $package, $file->[Youri::Package::FILE_MODE], $file->[Youri::Package::FILE_MD5SUM] ]
+ );
+ }
+ };
+
+ foreach my $media (@medias) {
+ # don't index source media files
+ next unless $media->get_type() eq 'binary';
+
+ my $media_id = $media->get_id();
+ $self->{_medias}->{$media_id} = 1;
+ print STDERR "Indexing media $media_id files\n"
+ if $self->{_verbose};
+
+ $media->traverse_headers($index);
+ }
+}
+
+sub run {
+ my ($self, $media, $result) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # this is a binary media check only
+ return unless $media->get_type() eq 'binary';
+
+ my $check = sub {
+ my ($package) = @_;
+
+ return if $package->get_arch() eq 'src';
+
+ my $arch = $package->get_arch();
+ my $name = $package->get_name();
+
+ foreach my $file ($package->get_files()) {
+
+ my $found =
+ $self->{_files}->{$file->[Youri::Package::FILE_NAME]};
+
+ my @found = $found ? @$found : ();
+
+ foreach my $found (@found) {
+ next if $found->[PACKAGE] == $package;
+ next unless compatible($found->[PACKAGE], $package);
+ next if conflict($found->[PACKAGE], $package);
+ next if replace($found->[PACKAGE], $package);
+ if (
+ ($file->[Youri::Package::FILE_MODE] & TYPE_MASK) == TYPE_DIR &&
+ ($found->[MODE] & TYPE_MASK) == TYPE_DIR
+ ) {
+ $result->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => "directory $file->[Youri::Package::FILE_NAME] duplicated with package " . $found->[PACKAGE]->get_name(),
+ level => Youri::Check::Input::WARNING
+ }) unless $self->_directory_duplicate_exception(
+ $package,
+ $found->[PACKAGE],
+ $file
+ );
+ } else {
+ if ($found->[MD5SUM] eq $file->[Youri::Package::FILE_MD5SUM]) {
+ $result->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => "file $file->[Youri::Package::FILE_NAME] duplicated with package " . $found->[PACKAGE]->get_name(),
+ level => Youri::Check::Input::WARNING
+ }) unless $self->_file_duplicate_exception(
+ $package,
+ $found->[PACKAGE],
+ $file
+ );
+ } else {
+ $result->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => "non-explicit conflict on file $file->[Youri::Package::FILE_NAME] with package " . $found->[PACKAGE]->get_name(),
+ level => Youri::Check::Input::ERROR
+ }) unless $self->_file_conflict_exception(
+ $package,
+ $found->[PACKAGE],
+ $file
+ );
+ }
+ }
+ }
+ }
+ };
+
+ $media->traverse_headers($check);
+}
+
+# return true if $package1 is arch-compatible with $package2
+sub compatible {
+ my ($package1, $package2) = @_;
+
+ my $arch1 = $package1->get_arch();
+ my $arch2 = $package2->get_arch();
+
+ return 1 if $arch1 eq $arch2;
+
+ return 1 if $compatibility->{$arch1} && $compatibility->{$arch1} eq $arch2;
+
+ return 0;
+}
+
+# return true if $package1 conflict with $package2
+# or the other way around
+sub conflict {
+ my ($package1, $package2) = @_;
+
+ my $name2 = $package2->get_name();
+
+ foreach my $conflict ($package1->get_conflicts()) {
+ return 1 if $conflict eq $name2;
+ }
+
+ my $name1 = $package1->get_name();
+
+ foreach my $conflict ($package2->get_conflicts()) {
+ return 1 if $conflict eq $name1;
+ }
+
+ return 0;
+}
+
+# return true if $package1 replace $package2
+sub replace {
+ my ($package1, $package2) = @_;
+
+
+ my $name1 = $package1->get_name();
+ my $name2 = $package2->get_name();
+
+ return 1 if $name1 eq $name2;
+
+ foreach my $obsolete ($package1->get_obsoletes()) {
+ return 1 if $obsolete->[Youri::Package::DEPENDENCY_NAME] eq $name2;
+ }
+
+ return 0;
+}
+
+sub _directory_duplicate_exception {
+ return 0;
+}
+
+sub _file_duplicate_exception {
+ return 0;
+}
+
+sub _file_conflict_exception {
+ return 0;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Dependencies.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Dependencies.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Dependencies.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,162 @@
+# $Id: Dependencies.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Dependencies;
+
+=head1 NAME
+
+Youri::Check::Input::Dependencies - Check dependencies consistency
+
+=head1 DESCRIPTION
+
+This class checks dependencies consistency.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Package;
+use base 'Youri::Check::Input';
+
+use constant MEDIA => 0;
+use constant RANGE => 1;
+
+sub columns {
+ return qw/
+ arch
+ file
+ error
+ level
+ /;
+}
+
+sub links {
+ return qw//;
+}
+
+sub prepare {
+ my ($self, @medias) = @_;
+ croak "Not a class method" unless ref $self;
+
+ foreach my $media (@medias) {
+ my $media_id = $media->get_id();
+ $self->{_medias}->{$media_id} = 1;
+ print STDERR "Indexing media $media_id dependencies\n"
+ if $self->{_verbose};
+
+ my $index = sub {
+ my ($package) = @_;
+
+ # index provides
+ foreach my $provide ($package->get_provides()) {
+ push(
+ @{$self->{_provides}->{$provide->[Youri::Package::DEPENDENCY_NAME]}},
+ [ $media_id, $provide->[Youri::Package::DEPENDENCY_RANGE] ]
+ );
+ }
+
+ # index files
+ foreach my $file ($package->get_files()) {
+ push(
+ @{$self->{_files}->{$file->[Youri::Package::FILE_NAME]}},
+ [ $media_id, undef ]
+ );
+ }
+ };
+ $media->traverse_headers($index);
+ }
+}
+
+sub run {
+ my ($self, $media, $resultset) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my @allowed_ids = $media->allow_deps();
+
+ # abort unless all allowed medias are present
+ foreach my $id (@allowed_ids) {
+ unless ($self->{_medias}->{$id}) {
+ carp "Missing media $id, aborting";
+ return;
+ }
+ }
+
+ # index allowed medias
+ my %allowed_ids = map { $_ => 1 } @allowed_ids;
+ my $allowed_ids = join(",", @allowed_ids);
+
+ my $class = $media->get_package_class();
+
+ my $check = sub {
+ my ($package) = @_;
+
+ my $arch = $package->get_arch();
+ my $name = $package->get_name();
+
+ foreach my $require ($package->get_requires()) {
+
+ my $found =
+ substr($require->[Youri::Package::DEPENDENCY_NAME], 0, 1) eq '/' ?
+ $self->{_files}->{$require->[Youri::Package::DEPENDENCY_NAME]} :
+ $self->{_provides}->{$require->[Youri::Package::DEPENDENCY_NAME]};
+
+ my @found = $found ? @$found : ();
+
+ if (!@found) {
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => "$require->[Youri::Package::DEPENDENCY_NAME] not found",
+ level => Youri::Check::Input::ERROR
+ });
+ next;
+ }
+
+ my @found_in_media =
+ grep { $allowed_ids{$_->[MEDIA]} }
+ @found;
+
+ if (!@found_in_media) {
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => "$require->[Youri::Package::DEPENDENCY_NAME] found in incorrect media $_->[MEDIA] (allowed $allowed_ids)",
+ level => Youri::Check::Input::ERROR
+ }) foreach @found;
+ next;
+ }
+
+ next unless $require->[Youri::Package::DEPENDENCY_RANGE];
+
+ my @found_in_range =
+ grep {
+ !$_->[RANGE] ||
+ $class->compare_ranges(
+ $require->[Youri::Package::DEPENDENCY_RANGE],
+ $_->[RANGE]
+ )
+ } @found_in_media;
+
+ if (!@found_in_range) {
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => "$require->[Youri::Package::DEPENDENCY_NAME] found with incorrect range $_->[RANGE] (needed $require->[Youri::Package::DEPENDENCY_RANGE])",
+ level => Youri::Check::Input::ERROR
+ }) foreach @found_in_media;
+ next;
+ }
+ }
+ };
+
+ $media->traverse_headers($check);
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/MandrivaConflicts.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/MandrivaConflicts.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/MandrivaConflicts.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Missing.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Missing.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Missing.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Orphans.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Orphans.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Orphans.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Rpmlint.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Rpmlint.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Rpmlint.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,113 @@
+# $Id: Rpmlint.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Rpmlint;
+
+=head1 NAME
+
+Youri::Check::Input::Rpmlint - Check packages with rpmlint
+
+=head1 DESCRIPTION
+
+This plugins checks packages with rpmlint, and reports output.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input';
+
+sub columns {
+ return qw/
+ arch
+ file
+ error
+ level
+ /;
+}
+
+sub links {
+ return qw//;
+}
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Rpmlint object.
+
+Specific parameters:
+
+=over
+
+=item path $path
+
+Path to the rpmlint executable (default: /usr/bin/rpmlint)
+
+=item config $config
+
+Specific rpmlint configuration.
+
+=back
+
+=cut
+
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ path => '/usr/bin/rpmlint', # path to rpmlint
+ config => '', # default rpmlint configuration
+ @_
+ );
+
+ $self->{_path} = $options{path};
+ $self->{_config} = $options{config};
+}
+
+sub run {
+ my ($self, $media, $resultset) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $config = $media->rpmlint_config() ?
+ $media->rpmlint_config() :
+ $self->{_config};
+
+ my $check = sub {
+ my ($file, $package) = @_;
+
+ my $arch = $package->get_arch();
+ my $name = $package->get_name();
+
+ my $command = "$self->{_path} -f $config $file";
+ open(RPMLINT, "$command |") or die "Can't run $command: $!";
+ while (<RPMLINT>) {
+ chomp;
+ if (/^E: \Q$name\E (.+)/) {
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => $1,
+ level => Youri::Check::Input::ERROR
+ });
+ } elsif (/^W: \Q$name\E (.+)/) {
+ $resultset->add_result($self->{_id}, $media, $package, {
+ arch => $arch,
+ file => $name,
+ error => $1,
+ level => Youri::Check::Input::WARNING
+ });
+ }
+ }
+ close(RPMLINT);
+ };
+
+ $media->traverse_files($check);
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Signature.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Signature.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Signature.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/CPAN.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/CPAN.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/CPAN.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,75 @@
+# $Id: CPAN.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::CPAN;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::CPAN - CPAN updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from CPAN.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::CPAN object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to CPAN full modules list (default:
+http://www.cpan.org/modules/01modules.index.html)
+
+=back
+
+=cut
+
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://www.cpan.org/modules/01modules.index.html',
+ @_
+ );
+
+ my $versions;
+ open(INPUT, "GET $options{url} |") or croak "Can't fetch $options{url}: $!";
+ while (<INPUT>) {
+ next unless $_ =~ />([\w-]+)-([\d\.]+)\.tar\.gz<\/a>/;
+ $versions->{$1} = $2;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://search.cpan.org/dist/$name";
+}
+
+sub _name {
+ my ($self, $name) = @_;
+ $name =~ s/^perl-//g;
+ return $name;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Debian.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Debian.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Debian.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,82 @@
+# $Id: Debian.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Debian;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Debian - Debian source for updates
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+ available from Debian.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Debian object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to Debian mirror content file (default: http://ftp.debian.org/ls-lR.gz)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://ftp.debian.org/ls-lR.gz',
+ @_
+ );
+
+ my $versions;
+ open(INPUT, "GET $options{url} | zcat |") or croak "Can't fetch $options{url}: $!";
+ while (my $line = <INPUT>) {
+ next unless $line =~ /([\w\.-]+)_([\d\.]+)\.orig\.tar\.gz$/;
+ my $name = $1;
+ my $version = $2;
+ $versions->{$name} = $version;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://packages.debian.org/$name";
+}
+
+sub _name {
+ my ($self, $name) = @_;
+
+ if ($name =~ /^(perl|ruby)-([-\w]+)$/) {
+ $name = lc("lib$2-$1");
+ } elsif ($name =~ /^apache-([-\w]+)$/) {
+ $name = "libapache-$1";
+ $name =~ s/_/-/g;
+ }
+
+ return $name;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Fedora.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Fedora.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Fedora.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,63 @@
+# $Id: Fedora.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Fedora;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Fedora - Fedora updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Fedora.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Fedora object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to Fedora development SRPMS directory (default:
+http://fr.rpmfind.net/linux/fedora/core/development/SRPMS)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://fr.rpmfind.net/linux/fedora/core/development/SRPMS',
+ @_
+ );
+
+ my $versions;
+ open(INPUT, "GET $options{url} |") or die "Can't fetch $options{url}: $!\n";
+ while (<INPUT>) {
+ next unless $_ =~ />([\w-]+)-([\w\.]+)-[\w\.]+\.src\.rpm<\/a>/;
+ $versions->{$1} = $2;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,111 @@
+# $Id: Freshmeat.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Freshmeat;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Freshmeat - Freshmeat source for updates
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Freshmeat.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use XML::Twig;
+use LWP::UserAgent;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Freshmeat
+object.
+
+Specific parameters:
+
+=over
+
+=item preload true/false
+
+Allows to load full Freshmeat catalogue at once instead of checking each software independantly (default: false)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ preload => 0,
+ @_
+ );
+
+ if ($options{preload}) {
+ my $versions;
+
+ my $project = sub {
+ my ($twig, $project) = @_;
+ my $name = $project->first_child('projectname_short')->text();
+ my $version = $project->first_child('latest_release')->first_child('latest_release_version')->text();
+ $versions->{$name} = $version;
+ $twig->purge();
+ };
+
+ my $twig = XML::Twig->new(
+ TwigRoots => { project => $project }
+ );
+
+ my $url = 'http://download.freshmeat.net/backend/fm-projects.rdf.bz2';
+
+ open(INPUT, "GET $url | bzcat |") or die "Can't fetch $url: $!\n";
+ $twig->parse(\*INPUT);
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+ }
+}
+
+sub _version {
+ my ($self, $name) = @_;
+
+ if ($self->{_versions}) {
+ return $self->{_versions}->{$name};
+ } else {
+ my $version;
+
+ my $latest_release_version = sub {
+ $version = $_[1]->text();
+ };
+
+ my $twig = XML::Twig->new(
+ TwigRoots => { latest_release_version => $latest_release_version }
+ );
+
+ my $url = "http://freshmeat.net/projects-xml/$name";
+
+ open(INPUT, "GET $url |") or die "Can't fetch $url: $!\n";
+ # freshmeat answer with an HTML page when project doesn't exist
+ $twig->safe_parse(\*INPUT);
+ close(INPUT);
+
+ return $version;
+ }
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://freshmeat.net/projects/$name";
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/GNOME.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/GNOME.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/GNOME.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Gentoo.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Gentoo.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Gentoo.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,75 @@
+# $Id: Gentoo.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Gentoo;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Gentoo - Gentoo updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Gentoo.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use LWP::Simple;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Gentoo object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to Gentoo snapshots directory (default:
+http://gentoo.mirror.sdv.fr/snapshots)
+
+=back
+
+=cut
+
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://gentoo.mirror.sdv.fr/snapshots', # default URL
+ @_
+ );
+
+ my $versions;
+ my $content = get($options{url});
+ my $file;
+ while ($content =~ /<A HREF="(portage-\d{8}.tar.bz2)">/g) {
+ $file = $1;
+ }
+ open(INPUT, "GET $options{url}/$file | tar tjf - |") or croak "Can't fetch $options{url}/$file: $!";
+ while (my $line = <INPUT>) {
+ next unless $line =~ /.*\/([\w-]+)-([\d\.]+)(:?-r\d)?\.ebuild$/;
+ $versions->{$1} = $2;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://packages.gentoo.org/search/?sstring=$name";
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/NetBSD.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/NetBSD.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/NetBSD.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/RAA.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/RAA.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/RAA.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,121 @@
+# $Id: RAA.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::RAA;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::RAA - RAA updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from RAA.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use SOAP::Lite;
+use List::MoreUtils 'any';
+use Youri::Package;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::RAA object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to RAA SOAP interface (default:
+http://www.ruby-lang.org/xmlns/soap/interface/RAA/0.0.4)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://www.ruby-lang.org/xmlns/soap/interface/RAA/0.0.4/',
+ @_
+ );
+
+ my $raa = SOAP::Lite->service($options{url})
+ or croak "Can't connect to $options{url}";
+
+ $self->{_raa} = $raa;
+ $self->{_names} = $raa->names();
+}
+
+sub get_version {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name;
+ if (ref $package && $package->isa('Youri::Package')) {
+ # don't bother checking for non-ruby packages
+ if (
+ any { $_->[Youri::Package::DEPENDENCY_NAME] =~ /ruby/ }
+ $package->get_requires()
+ ) {
+ $name = $package->get_canonical_name();
+ } else {
+ return;
+ }
+ } else {
+ $name = $package;
+ }
+
+ # translate in grabber namespace
+ $name = $self->get_name($name);
+
+ # return if aliased to null
+ return unless $name;
+
+ # susceptible to throw exception for timeout
+ eval {
+ my $gem = $self->{_raa}->gem($name);
+ return $gem->{project}->{version} if $gem;
+ };
+
+ return;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://raa.ruby-lang.org/project/$name/";
+}
+
+sub _name {
+ my ($self, $name) = @_;
+
+ if (ref $self) {
+ my $match = $name;
+ $match =~ s/^ruby[-_]//;
+ $match =~ s/[-_]ruby$//;
+ my @results =
+ grep { /^(ruby[-_])?\Q$match\E([-_]ruby)$/ }
+ @{$self->{_names}};
+ if (@results) {
+ return $results[0];
+ } else {
+ return $name;
+ }
+ } else {
+ return $name;
+ }
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,103 @@
+# $Id: Sourceforge.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Sourceforge;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Sourceforge - Sourceforge updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Sourceforge.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use LWP::UserAgent;
+use HTML::TokeParser;
+use Youri::Check::Input::Updates;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Sourceforge
+object.
+
+No specific parameters.
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ @_
+ );
+
+ $self->{_agent} = LWP::UserAgent->new();
+}
+
+sub get_version {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name;
+ if (ref $package && $package->isa('Youri::Package')) {
+ # don't bother checking for packages without sf.net URL
+ my $url = $package->get_url();
+ if (
+ $url =~ /http:\/\/(.*)\.sourceforge\.net/ ||
+ $url =~ /http:\/\/.*sourceforge\.net\/projects\/([^\/]+)/
+ ) {
+ $name = $package->get_canonical_name();
+ } else {
+ return;
+ }
+ } else {
+ $name = $package;
+ }
+
+ # translate in grabber namespace
+ $name = $self->get_name($name);
+
+ # return if aliased to null
+ return unless $name;
+
+ my $response = $self->{_agent}->get($self->_url($name));
+ if($response->is_success()) {
+ my $max = 0;
+ my $parser = HTML::TokeParser->new(\$response->content());
+ while (my $token = $parser->get_tag('a')) {
+ my $text = $parser->get_trimmed_text("/$token->[0]");
+ next unless $text;
+ next unless $text =~ /^
+ \Q$name\E
+ [._-]?($Youri::Check::Input::Updates::VERSION_REGEXP)
+ [._-]?(w(?:in)?(?:32)?|mips|sparc|bin|ppc|i\d86|src|sources?)?
+ \.(?:tar\.(?:gz|bz2)|tgz|zip)
+ $/iox;
+ my $version = $1;
+ my $arch = $2;
+ next if $arch && $arch !~ /(src|sources?)/;
+ $max = $version if Youri::Check::Input::Updates::is_newer($version, $max);
+ }
+ return $max if $max;
+ }
+ return;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://prdownloads.sourceforge.net/$name/";
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates/Source.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,240 @@
+# $Id: Source.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source - Abstract updates source
+
+=head1 DESCRIPTION
+
+This abstract class defines the updates source interface for
+L<Youri::Check::Input::Updates>.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates object.
+
+Generic parameters (subclasses may define additional ones):
+
+=over
+
+=item aliases $aliases
+
+Hash of package aliases.
+
+=back
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ id => '', # object id
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ aliases => undef, # aliases
+ resolver => undef, # maintainer resolver
+ preferences => undef, # maintainer preferences
+ check_id => '', # parent check id
+ @_
+ );
+
+ if ($options{aliases}) {
+ croak "aliases should be an hashref" unless ref $options{aliases} eq 'HASH';
+ }
+ if ($options{resolver}) {
+ croak "resolver should be a Youri::Check::Maintainer::Resolver object" unless $options{resolver}->isa("Youri::Check::Maintainer::Resolver");
+ }
+ if ($options{preferences}) {
+ croak "preferences should be a Youri::Check::Maintainer::Preferences object" unless $options{preferences}->isa("Youri::Check::Maintainer::Preferences");
+ }
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ _aliases => $options{aliases},
+ _resolver => $options{resolver},
+ _preferences => $options{preferences},
+ _check_id => $options{check_id},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+Excepted explicit statement, package name is expressed with Mandriva naming
+conventions.
+
+=head2 get_id()
+
+Returns source identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 get_version($package)
+
+Returns available version for given package, which can be either a full
+L<Youri::Package> object or just a package name.
+
+=cut
+
+sub get_version {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name = ref $package && $package->isa('Youri::Package') ?
+ $package->get_canonical_name() :
+ $package;
+
+ # translate in grabber namespace
+ $name = $self->get_name($name);
+
+ # return if aliased to null
+ return unless $name;
+
+ # return subclass computation
+ return $self->_version($name);
+}
+
+=head2 get_url($name)
+
+Returns the URL of information source for package with given name.
+
+=cut
+
+sub get_url {
+ my ($self, $name) = @_;
+
+ # retun subclass computation
+ return $self->_url($self->get_name($name));
+}
+
+=head2 name($name)
+
+Returns name converted to specific source naming conventions for package with given name.
+
+=cut
+
+sub get_name {
+ my ($self, $name) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # return config aliases if it exists
+ if ($self->{_aliases} ) {
+ return $self->{_aliases}->{$name} if exists $self->{_aliases}->{$name};
+ }
+
+ # return maintainer aliases if it exists
+ if ($self->{_resolver} && $self->{_preferences}) {
+ my $maintainer = $self->{_resolver}->get_maintainer($name);
+ if ($maintainer) {
+ my $aliases = $self->{_preferences}->get_preference(
+ $maintainer,
+ $self->{_check_id},
+ 'aliases'
+ );
+ if ($aliases) {
+ if ($aliases->{all}) {
+ return $aliases->{all}->{$name} if exists $aliases->{all}->{$name};
+ }
+ if ($aliases->{$self->{_id}}) {
+ return $aliases->{$self->{_id}}->{$name} if exists $aliases->{$self->{_id}}->{$name};
+ }
+ }
+ }
+ }
+
+ # return return subclass computation
+ return $self->_name($name);
+}
+
+=head2 _version($name)
+
+Hook called by default B<version()> implementation after name translation.
+
+=cut
+
+sub _version {
+ my ($self, $name) = @_;
+ return $self->{_versions}->{$name};
+}
+
+=head2 _url($name)
+
+Hook called by default B<url()> implementation after name translation.
+
+=cut
+
+sub _url {
+ my ($self, $name) = @_;
+ return undef;
+}
+
+=head2 _name($name)
+
+Hook called by default B<name()> implementation if given name was not found in
+the aliases.
+
+=cut
+
+sub _name {
+ my ($self, $name) = @_;
+ return $name;
+}
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item version
+
+As an alternative, the B<_version()> hook can be implemented.
+
+=item url
+
+As an alternative, the <_url()> hook can be implemented.
+
+=item name
+
+As an alternative, the B<_name()> hook can be implemented.
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input/Updates.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,275 @@
+# $Id: Updates.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates;
+
+=head1 NAME
+
+Youri::Check::Input::Updates - Check available updates
+
+=head1 DESCRIPTION
+
+This plugin checks available updates for packages, and report existing ones.
+Additional source plugins handle specific sources.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Memoize;
+use Youri::Utils;
+use base 'Youri::Check::Input';
+
+sub columns {
+ return qw/
+ current
+ available
+ source
+ /;
+}
+
+sub links {
+ return qw/
+ source url
+ /;
+}
+
+memoize('is_newer');
+
+our $VERSION_REGEXP = 'v?([\d._-]*\d)[._ -]*(?:(alpha|beta|pre|rc|pl|rev|cvs|svn|[a-z])[_ -.]*([\d.]*))?([_ -.]*.*)';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates object.
+
+Specific parameters:
+
+=over
+
+=item aliases $aliases
+
+Hash of global aliases definitions
+
+=item sources $sources
+
+Hash of source plugins definitions
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ aliases => undef,
+ sources => undef,
+ @_
+ );
+
+ croak "No source defined" unless $options{sources};
+ croak "sources should be an hashref" unless ref $options{sources} eq 'HASH';
+ if ($options{aliases}) {
+ croak "aliases should be an hashref" unless ref $options{aliases} eq 'HASH';
+ }
+
+ foreach my $id (keys %{$options{sources}}) {
+ print "Creating source $id\n" if $options{verbose};
+ eval {
+ # add global aliases if defined
+ if ($options{aliases}) {
+ foreach my $alias (keys %{$options{aliases}}) {
+ $options{sources}->{$id}->{aliases}->{$alias} =
+ $options{aliases}->{$alias}
+ }
+ }
+
+ push(
+ @{$self->{_sources}},
+ create_instance(
+ 'Youri::Check::Input::Updates::Source',
+ id => $id,
+ test => $options{test},
+ verbose => $options{verbose},
+ check_id => $options{id},
+ resolver => $options{resolver},
+ preferences => $options{preferences},
+ %{$options{sources}->{$id}}
+ )
+ );
+ };
+ print STDERR "Failed to create source $id: $@\n" if $@;
+ }
+
+ croak "no sources created" unless @{$self->{_sources}};
+}
+
+sub run {
+ my ($self, $media, $resultset) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # this is a source media check only
+ return unless $media->get_type() eq 'source';
+
+ my $callback = sub {
+ my ($package) = @_;
+
+ my $name = $package->get_name();
+ my $version = $package->get_version();
+ my $release = $package->get_release();
+
+ # compute version with rpm subtilities related to preversions
+ my $current_version = ($release =~ /^0\.(\w+)\.\w+$/) ?
+ $version . $1 :
+ $version;
+ my $current_stable = is_stable($current_version);
+
+ my ($max_version, $max_source, $max_url);
+ $max_version = $current_version;
+
+ foreach my $source (@{$self->{_sources}}) {
+ my $available_version = $source->get_version($package);
+ if (
+ $available_version &&
+ (! $current_stable || is_stable($available_version)) &&
+ is_newer($available_version, $max_version)
+ ) {
+ $max_version = $available_version;
+ $max_source = $source->get_id();
+ $max_url = $source->get_url($name);
+ }
+ }
+ $resultset->add_result($self->{_id}, $media, $package, {
+ current => $current_version,
+ available => $max_version,
+ source => $max_source,
+ url => $max_url
+ }) if $max_version ne $current_version;
+ };
+
+ $media->traverse_headers($callback);
+}
+
+=head2 is_stable($version)
+
+Checks if given version is stable.
+
+=cut
+
+sub is_stable {
+ my ($version) = @_;
+ return $version !~ /alpha|beta|pre|rc|cvs|svn/i;
+
+}
+
+=head2 is_newer($v1, $v2)
+
+Checks if $v1 is newer than $v2.
+
+This function will return true only if we are sure this is newer (and not equal).
+If we can't compare the versions, a warning will be displayed.
+
+=cut
+
+sub is_newer {
+ my ($v1, $v2) = @_;
+ return 0 if $v1 eq $v2;
+
+ # Reject strange cases
+ # One is a large number (like date or revision) and the other one not, or
+ # has different length
+ if (($v1 =~ /^\d{3,}$/ || $v2 =~ /^\d{3,}$/)
+ && (join('0',split(/\d/, $v1."X")) ne join('0',split(/\d/, $v2."X")))) {
+ carp "strange : $v1 vs $v2";
+ return 0;
+ }
+
+ my %states = (alpha=>-4,beta=>-3,pre=>-2,rc=>-1);
+ my $i; $states{$_} = ++$i foreach 'a'..'z';
+
+ if ($v1 =~ /^[\d._-]+$/ && $v2 =~ /^[\d._-]+$/) {
+ my @v1 = split(/[._-]/, $v1);
+ my @v2 = split(/[._-]/, $v2);
+ if (join('', at v1) eq (join '', at 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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Input.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Input.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Input.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,120 @@
+# $Id: Input.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input;
+
+=head1 NAME
+
+Youri::Check::Input - Abstract input plugin
+
+=head1 DESCRIPTION
+
+This abstract class defines input plugin interface.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Utils;
+
+use constant WARNING => 'warning';
+use constant ERROR => 'error';
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input object.
+
+No generic parameters (subclasses may define additional ones).
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ id => '', # object id
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ resolver => undef, # maintainer resolver
+ preferences => undef, # maintainer preferences
+ @_
+ );
+
+ if ($options{resolver}) {
+ croak "resolver should be a Youri::Check::Maintainer::Resolver object" unless $options{resolver}->isa("Youri::Check::Maintainer::Resolver");
+ }
+ if ($options{preferences}) {
+ croak "preferences should be a Youri::Check::Maintainer::Preferences object" unless $options{preferences}->isa("Youri::Check::Maintainer::Preferences");
+ }
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ _resolver => $options{resolver},
+ _preferences => $options{preferences},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+=head2 get_id()
+
+Returns plugin identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 prepare(@medias)
+
+Perform optional preliminary initialisation, using given list of
+<Youri::Media> objects.
+
+=cut
+
+sub prepare {
+ # do nothing
+}
+
+=head2 run($media, $resultset)
+
+Check the packages from given L<Youri::Media> object, and store the
+result in given L<Youri::Check::Resultset> object.
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item run
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences/File.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences/File.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences/File.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,87 @@
+# $Id: File.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Maintainer::Preferences::File;
+
+=head1 NAME
+
+Youri::Check::Maintainer::Preferences::File - File-based maintainer preferences implementation
+
+=head1 DESCRIPTION
+
+This is a file-based L<Youri::Check::Maintainer::Preferences> implementation.
+
+It uses files in maintainer home directories.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Config;
+use base 'Youri::Check::Maintainer::Preferences';
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Maintainer::Preferences::File object.
+
+No specific parameters.
+
+=cut
+
+sub get_preference {
+ my ($self, $maintainer, $plugin, $value) = @_;
+ croak "Not a class method" unless ref $self;
+ return unless $maintainer && $plugin && $value;
+
+ print "Retrieving maintainer $maintainer preferences\n"
+ if $self->{_verbose} > 0;
+
+ $self->_load_config($maintainer)
+ unless exists $self->{_config}->{$maintainer};
+
+ return $self->{_config}->{$maintainer} ?
+ $self->{_config}->{$maintainer}->get($plugin . '_' . $value) :
+ undef;
+}
+
+sub _load_config {
+ my ($self, $maintainer) = @_;
+
+ print "Attempting to load maintainers preferences for $maintainer\n" if $self->{_verbose} > 1;
+
+
+ my ($login) = $maintainer =~ /^(\S+)\@\S+$/;
+ my $home = (getpwnam($login))[7];
+ my $file = "$home/.youri/check.prefs";
+
+ if (-f $file && -r $file) {
+ print "Found, loading\n" if $self->{_verbose} > 1;
+ my $config = Youri::Config->new(
+ {
+ CREATE => 1,
+ GLOBAL => {
+ DEFAULT => undef,
+ EXPAND => EXPAND_VAR | EXPAND_ENV,
+ ARGCOUNT => ARGCOUNT_ONE,
+ }
+ }
+ );
+ $config->file($file);
+ $self->{_config}->{$maintainer} = $config;
+ } else {
+ print "Not found, aborting\n" if $self->{_verbose} > 1;
+ $self->{_config}->{$maintainer} = undef;
+ }
+
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Preferences.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,80 @@
+# $Id: Preferences.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Maintainer::Preferences;
+
+=head1 NAME
+
+Youri::Check::Maintainer::Preferences - Abstract maintainer preferences
+
+=head1 DESCRIPTION
+
+This abstract class defines Youri::Check::Maintainer::Preferences interface.
+
+=head1 SYNOPSIS
+
+ use Youri::Check::Maintainer::Preferences::Foo;
+
+ my $preferences = Youri::Check::Maintainer::Preferences::Foo->new();
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Maintainer::Preferences object.
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ @_
+ );
+
+ my $self = bless {
+ _test => $options{test},
+ _verbose => $options{verbose},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head2 get_preference($maintainer, $plugin, $item)
+
+Returns preference of given maintainer for given plugin and configuration item.
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item get
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/Bugzilla.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,100 @@
+# $Id: Bugzilla.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Maintainer::Resolver::Bugzilla;
+
+=head1 NAME
+
+Youri::Check::Maintainer::Resolver::Bugzilla - Bugzilla-based maintainer resolver
+
+=head1 DESCRIPTION
+
+This is a Bugzilla-based L<Youri::Check::Maintainer::Resolver> implementation.
+
+It uses Bugzilla SQL database for resolving maintainers.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Bugzilla;
+use base 'Youri::Check::Maintainer::Resolver';
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Maintainer::Resolver::Bugzilla object.
+
+Specific parameters:
+
+=over
+
+=item host $host
+
+Bugzilla database host.
+
+=item base $base
+
+Bugzilla database name.
+
+=item user $user
+
+Bugzilla database user.
+
+=item pass $pass
+
+Bugzilla database password.
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ host => '', # host of the bug database
+ base => '', # name of the bug database
+ user => '', # user of the bug database
+ pass => '', # pass of the bug database
+ @_
+ );
+
+ croak "No host given" unless $options{host};
+ croak "No base given" unless $options{base};
+ croak "No user given" unless $options{user};
+ croak "No pass given" unless $options{pass};
+
+ my $bugzilla = Youri::Bugzilla->new(
+ $options{host},
+ $options{base},
+ $options{user},
+ $options{pass}
+ );
+
+ $self->{_bugzilla} = $bugzilla;
+}
+
+sub get_maintainer {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name = ref $package && $package->isa('Youri::Package') ?
+ $package->get_canonical_name() :
+ $package;
+
+ $self->{_maintainers}->{$name} =
+ $self->{_bugzilla}->get_maintainer($name)
+ unless exists $self->{_maintainers}->{$name};
+
+ return $self->{_maintainers}->{$name};
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/CGI.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/CGI.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver/CGI.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,79 @@
+# $Id: CGI.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Maintainer::Resolver::CGI;
+
+=head1 NAME
+
+Youri::Check::Maintainer::Resolver::CGI - CGI-based maintainer resolver
+
+=head1 DESCRIPTION
+
+This is a CGI-based L<Youri::Check::Maintainer::Resolver> implementation.
+
+It uses a remote CGI to resolve maintainers.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Maintainer::Resolver';
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Maintainer::Resolver::CGI object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+CGI's URL.
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => '', # url to fetch maintainers
+ @_
+ );
+
+ croak "No URL given" unless $options{url};
+
+ open (INPUT, "GET $options{url} |");
+ while (<INPUT>) {
+ chomp;
+ my ($package, $maintainer) = split(/\t/, $_);
+ $self->{_maintainers}->{$package} = $maintainer if $maintainer;
+ }
+ close(INPUT);
+}
+
+sub get_maintainer {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ print "Retrieving package $package maintainer\n"
+ if $self->{_verbose} > 0;
+
+ my $name = ref $package && $package->isa('Youri::Package') ?
+ $package->get_canonical_name() :
+ $package;
+
+ return $self->{_maintainers}->{$name};
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Maintainer/Resolver.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,86 @@
+# $Id: Resolver.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Maintainer::Resolver;
+
+=head1 NAME
+
+Youri::Check::Maintainer::Resolver - Abstract maintainer resolver
+
+=head1 DESCRIPTION
+
+This abstract class defines Youri::Check::Maintainer::Resolver interface.
+
+=head1 SYNOPSIS
+
+ use Youri::Check::Maintainer::Resolver::Foo;
+
+ my $resolver = Youri::Check::Maintainer::Resolver::Foo->new();
+
+ print $resolver->get_maintainer('foo');
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Utils;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Maintainer::Resolver object.
+
+No generic parameters (subclasses may define additional ones).
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ @_
+ );
+
+ my $self = bless {
+ _test => $options{test},
+ _verbose => $options{verbose}
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head2 get_maintainer($package)
+
+Returns maintainer for given package, which can be either a full
+L<Youri::Package> object or just a package name.
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item get_maintainer
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/HTML.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/HTML.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/HTML.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,222 @@
+# $Id: HTML.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Output::File::Format::HTML;
+
+=head1 NAME
+
+Youri::Check::Output::File::Format::HTML - File HTML format support
+
+=head1 DESCRIPTION
+
+This format plugin for L<Youri::Check::Output::File> provides HTML format
+support.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use CGI;
+use base 'Youri::Check::Output::File::Format';
+
+sub extension {
+ return 'html';
+}
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ style => <<EOF, # css style
+h1 {
+ text-align:center;
+}
+table {
+ border-style:solid;
+ border-width:1px;
+ border-color:black;
+ width:100%;
+}
+tr.odd {
+ background-color:white;
+}
+tr.even {
+ background-color:silver;
+}
+p.footer {
+ font-size:smaller;
+ text-align:center;
+}
+EOF
+ @_
+ );
+
+ $self->{_style} = $options{style};
+ $self->{_cgi} = CGI->new();
+}
+
+sub get_report {
+ my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_;
+
+ my $content;
+ my $lead_columns = [
+ $maintainer ?
+ qw/package media/ :
+ qw/package media maintainer/
+ ];
+ my $line;
+ my @results;
+ $content .= $self->{_cgi}->start_table();
+ $content .= $self->{_cgi}->Tr([
+ $self->{_cgi}->th([
+ @$lead_columns,
+ @$columns
+ ])
+ ]);
+ while (my $result = $iterator->get_result()) {
+ if (@results && $result->{package} ne $results[0]->{package}) {
+ $content .= $self->_get_formated_results(
+ $lead_columns,
+ $columns,
+ $links,
+ $line++ % 2 ? 'odd' : 'even',
+ \@results
+ );
+ @results = ();
+ }
+ push(@results, $result);
+ }
+ $content .= $self->_get_formated_results(
+ $lead_columns,
+ $columns,
+ $links,
+ $line++ % 2 ? 'odd' : 'even',
+ \@results
+ );
+ $content .= $self->{_cgi}->end_table();
+
+ return $self->_get_html_page($time, $title, \$content);
+}
+
+sub get_index {
+ my ($self, $time, $title, $reports, $maintainers) = @_;
+
+ my $content;
+
+ if ($reports) {
+ $content .= $self->{_cgi}->h2("Reports");
+ my @types = keys %{$reports};
+
+ $content .= $self->{_cgi}->start_ul();
+ foreach my $type (sort @types) {
+ my $item;
+ $item = $self->{_cgi}->a(
+ { href => "$type.html" },
+ $type
+ );
+ foreach my $extension (@{$reports->{$type}}) {
+ next if ($extension eq extension());
+ $item .= " ".$self->{_cgi}->a(
+ { href => "$type.$extension" },
+ "[$extension]"
+ );
+ }
+ $content .= $self->{_cgi}->li($item);
+ }
+ $content .= $self->{_cgi}->end_ul();
+ }
+
+ if ($maintainers) {
+ $content .= $self->{_cgi}->h2("Individual reports");
+
+ $content .= $self->{_cgi}->start_ul();
+ foreach my $maintainer (sort @{$maintainers}) {
+ $content .= $self->{_cgi}->li(
+ $self->{_cgi}->a(
+ { href => "$maintainer/index.html" },
+ _obfuscate($maintainer)
+ )
+ );
+ }
+ $content .= $self->{_cgi}->end_ul();
+ }
+
+ return $self->_get_html_page($time, $title, \$content);
+}
+
+sub _get_formated_results {
+ my ($self, $lead_columns, $columns, $links, $class, $results) = @_;
+
+ my $content;
+ $content .= $self->{_cgi}->end_Tr();
+ for my $i (0 .. $#$results) {
+ $content .= $self->{_cgi}->start_Tr(
+ { class => $class }
+ );
+ if ($i == 0) {
+ # first line contains spanned cells
+ $content .= $self->{_cgi}->td(
+ { rowspan => scalar @$results },
+ [
+ map { $results->[$i]->{$_} }
+ @$lead_columns
+ ]
+ );
+ }
+ $content .= $self->{_cgi}->td(
+ [
+ map {
+ $links->{$_} && $results->[$i]->{$links->{$_}} ?
+ $self->{_cgi}->a(
+ { href => $results->[$i]->{$links->{$_}} },
+ $self->{_cgi}->escapeHTML($results->[$i]->{$_})
+ ) :
+ $self->{_cgi}->escapeHTML($results->[$i]->{$_})
+ } @$columns
+ ]
+ );
+ $content .= $self->{_cgi}->end_Tr();
+ }
+
+ return $content;
+}
+
+
+sub _get_html_page {
+ my ($self, $time, $title, $body) = @_;
+
+ my $content;
+ $content .= $self->{_cgi}->start_html(
+ -title => $title,
+ -style => { code => $self->{_style} }
+ );
+ $content .= $self->{_cgi}->h1($title);
+ $content .= $$body;
+ $content .= $self->{_cgi}->hr();
+ $content .= $self->{_cgi}->p(
+ { class => 'footer' },
+ "Page generated $time"
+ );
+ $content .= $self->{_cgi}->end_html();
+
+ return \$content;
+}
+
+sub _obfuscate {
+ my ($email) = @_;
+
+ return unless $email;
+
+ $email =~ s/\@/ at /;
+ $email =~ s/\./ dot /;
+
+ return $email;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/RSS.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/RSS.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/RSS.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/Text.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/Text.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format/Text.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,88 @@
+# $Id: Text.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Output::File::Format::Text;
+
+=head1 NAME
+
+Youri::Check::Output::File::Format::Text - File text format support
+
+=head1 DESCRIPTION
+
+This format plugin for L<Youri::Check::Output::File> provides text format
+support.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Output::File::Format';
+
+sub extension {
+ return 'txt';
+}
+
+sub get_report {
+ my ($self, $time, $title, $iterator, $type, $columns, $links, $maintainer) = @_;
+
+ my $content;
+ $content .= $title;
+ $content .= "\n";
+
+ my $lead_columns = [
+ $maintainer ?
+ qw/package media/ :
+ qw/package media maintainer/
+ ];
+ my @results;
+ $content .= join("\t", @$lead_columns, @$columns) . "\n";
+ while (my $result = $iterator->get_result()) {
+ if (@results && $result->{package} ne $results[0]->{package}) {
+ $content .= $self->_get_formated_results(
+ $lead_columns,
+ $columns,
+ \@results
+ );
+ @results = ();
+ }
+ push(@results, $result);
+ }
+ $content .= $self->_get_formated_results(
+ $lead_columns,
+ $columns,
+ \@results
+ );
+
+ $content .= "\n";
+ $content .= "Page generated $time\n";
+
+ return \$content;
+}
+
+sub _get_formated_results {
+ my ($self, $lead_columns, $columns, $results) = @_;
+
+ my $content;
+ $content .= join(
+ "\t",
+ (map { $results->[0]->{$_} || '' } @$lead_columns),
+ (map { $results->[0]->{$_} || '' } @$columns)
+ ) . "\n";
+ for my $i (1 .. $#$results) {
+ $content .= join(
+ "\t",
+ (map { '' } @$lead_columns),
+ (map { $results->[$i]->{$_} || '' } @$columns)
+ ) . "\n";
+ }
+ return $content;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File/Format.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/File.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/HTML.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/HTML.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/HTML.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/Text.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/Text.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format/Text.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail/Format.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output/Mail.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,156 @@
+# $Id: Mail.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Output::Mail;
+
+=head1 NAME
+
+Youri::Check::Output::Mail - Report results by mail
+
+=head1 DESCRIPTION
+
+This plugin reports results by mail. Additional subplugins handle specific
+formats.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use MIME::Entity;
+use Youri::Utils;
+use base 'Youri::Check::Output';
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ from => '', # mail from header
+ to => '', # mail to header
+ reply_to => '', # mail reply-to header
+ mta => '', # mta path
+ noempty => 1, # don't generate empty reports
+ formats => {},
+ @_
+ );
+
+ croak "no format defined" unless $options{formats};
+ croak "formats should be an hashref" unless ref $options{formats} eq 'HASH';
+
+ $self->{_from} = $options{from};
+ $self->{_to} = $options{to};
+ $self->{_reply_to} = $options{reply_to};
+ $self->{_mta} = $options{mta};
+ $self->{_noempty} = $options{noempty};
+
+ foreach my $id (keys %{$options{formats}}) {
+ print "Creating format $id\n" if $options{verbose};
+ eval {
+ push(
+ @{$self->{_formats}},
+ create_instance(
+ 'Youri::Check::Output::Mail::Format',
+ id => $id,
+ test => $options{test},
+ verbose => $options{verbose},
+ %{$options{formats}->{$id}}
+ )
+ );
+ };
+ print STDERR "Failed to create format $id: $@\n" if $@;
+ }
+
+ croak "no formats created" unless @{$self->{_formats}};
+}
+
+sub _global_report {
+ my ($self, $resultset, $type, $columns, $links) = @_;
+
+ foreach my $format (@{$self->{_formats}}) {
+ my $iterator = $resultset->get_iterator(
+ $type,
+ [ 'package' ]
+ );
+
+ return if $self->{_noempty} && ! $iterator->has_results();
+
+ my $content = $format->get_report(
+ $self->{_time},
+ "$type global report",
+ $iterator,
+ $type,
+ $columns,
+ $links,
+ undef
+ );
+
+ $self->_send_mail(
+ $format->type(),
+ $self->{_to},
+ "$type global report",
+ $content,
+ );
+ }
+}
+
+sub _individual_report {
+ my ($self, $resultset, $type, $columns, $links, $maintainer) = @_;
+
+ foreach my $format (@{$self->{_formats}}) {
+ my $iterator = $resultset->get_iterator(
+ $type,
+ [ 'package' ],
+ { maintainer => [ $maintainer ] }
+ );
+
+ return if $self->{_noempty} && ! $iterator->has_results();
+
+ my $content = $format->get_report(
+ $self->{_time},
+ "$type individual report for $maintainer",
+ $iterator,
+ $type,
+ $columns,
+ $links,
+ $maintainer
+ );
+
+ $self->_send_mail(
+ $format->type(),
+ $maintainer,
+ "$type individual report for $maintainer",
+ $content,
+ );
+ }
+
+}
+
+sub _send_mail {
+ my ($self, $type, $to, $subject, $content) = @_;
+
+ return unless $content;
+
+ my $mail = MIME::Entity->build(
+ 'Type' => $type,
+ 'From' => $self->{_from},
+ 'Reply-To' => $self->{_reply_to},
+ 'To' => $to,
+ 'Subject' => $subject,
+ 'Data' => $$content
+ );
+
+ if ($self->{_test}) {
+ $mail->print(\*STDOUT);
+ } else {
+ open(MAIL, "| $self->{_mta} -t -oi -oem") or die "Can't open MTA program: $!";
+ $mail->print(\*MAIL);
+ close MAIL;
+ }
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Output.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Output.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Output.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,190 @@
+# $Id: Output.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Output;
+
+=head1 NAME
+
+Youri::Check::Output - Abstract output plugin
+
+=head1 DESCRIPTION
+
+This abstract class defines output plugin interface.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Youri::Utils;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Output object.
+
+Generic parameters (subclasses may define additional ones):
+
+=over
+
+=item global true/false
+
+Global reports generation (default: true).
+
+=item individual true/false
+
+Individual reports generation (default: true).
+
+=back
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ id => '',
+ test => 0,
+ verbose => 0,
+ global => 1,
+ individual => 1,
+ config => undef,
+ @_
+ );
+
+ croak "Neither global nor individual reporting selected" unless $options{global} || $options{individual};
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ _global => $options{global},
+ _individual => $options{individual},
+ _config => $options{config}
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+=head2 get_id()
+
+Returns plugin identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 run($resultset)
+
+Reports the result stored in given L<Youri::Check::Resultset> object.
+
+=cut
+
+sub run {
+ my ($self, $resultset) = @_;
+
+ $self->_init_report();
+
+ # get types and maintainers list from resultset
+ my @maintainers = $resultset->get_maintainers();
+ my @types = $resultset->get_types();
+
+ foreach my $type (@types) {
+ # get formatting instructions from class
+ my $class = $self->{_config}->get($type . '_class');
+ load($class);
+ my @columns = $class->columns();
+ my %links = $class->links();
+
+ if ($self->{_global}) {
+ print STDERR "generating global report for $type\n" if $self->{_verbose};
+ $self->_global_report(
+ $resultset,
+ $type,
+ \@columns,
+ \%links
+ );
+ }
+
+ if ($self->{_individual}) {
+ foreach my $maintainer (@maintainers) {
+ print STDERR "generating individual report for $type and $maintainer\n" if $self->{_verbose};
+
+ $self->_individual_report(
+ $resultset,
+ $type,
+ \@columns,
+ \%links,
+ $maintainer
+ );
+ }
+ }
+ }
+
+ $self->_finish_report(\@types, \@maintainers);
+}
+
+sub _init_report {
+ # do nothing
+}
+
+sub _global_report {
+ # do nothing
+}
+
+sub _individual_report {
+ # do nothing
+}
+
+sub _finish_report {
+ # do nothing
+}
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item run
+
+As an alternative, the following hooks can be implemented:
+
+=over
+
+=item _init_report
+
+=item _global_report
+
+=item _individual_report
+
+=item _finish_report
+
+=back
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/DBI.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/DBI.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/DBI.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/Iterator.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/Iterator.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset/Iterator.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Check/Resultset.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Config.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Config.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Config.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,202 @@
+# $Id: Config.pm 1709 2006-10-16 16:33:43Z warly $
+package Youri::Config;
+
+=head1 NAME
+
+Youri::Application - Youri application handler
+
+=head1 SYNOPSIS
+
+ use Youri::Application;
+
+ my $app = Youri::Application->new(
+ options => {
+ help => '|h!'
+ },
+ directories => [ '/etc/youri', "$ENV{HOME}/.youri" ],
+ file => 'app.conf',
+ );
+
+ # get command line argument
+ my $foo = $app->get_arg('foo');
+
+ # get configuration file parameter
+ my $bar = $app->get_param('bar');
+
+=head1 DESCRIPTION
+
+This class handle configuration for all YOURI applications.
+
+The command line specification is used to manage arguments through
+Getopt::Long. Unless B<--config> argument is given, the list of directories is
+then scanned for a file with given name, and halt as soon as it find one. If no
+readable file is found, an exception is thrown. The file is then processed
+through YAML::AppConfig. If parsing fails, an exception is thrown.
+
+=head1 CONFIGURATION FILE FORMAT
+
+=head2 SHARED KEYS
+
+In addition to the application-specific optional or mandatory parameters, all
+YOURI applications support the following optional top-level parameters:
+
+=over
+
+=item B<includes>
+
+A list of additional configuration files.
+
+=item B<foo>
+
+An arbitrary variable, usable everywhere else in the file.
+
+=back
+
+=head2 PLUGIN DEFINITION
+
+All YOURI application heavily rely on plugins defined in their configuration
+files. A plugin definition is composed from the following parameters:
+
+=over
+
+=item B<class>
+
+The class of this plugin.
+
+=item B<options>
+
+The options of this plugin.
+
+=back
+
+=head1 SEE ALSO
+
+YAML::AppConfig, Getopt::Long
+
+=cut
+
+use strict;
+use warnings;
+use YAML::AppConfig;
+use Getopt::Long;
+use File::Spec;
+use Pod::Usage;
+use Carp;
+
+sub new {
+ my ($class, %options) = @_;
+
+
+ # command line arguments
+ my $args = {
+ verbose => 0
+ };
+ my @args;
+ if ($options{args}) {
+ while (my ($arg, $spec) = each %{$options{args}}) {
+ push(@args, ($arg . $spec) => \$args->{$arg});
+ }
+ }
+ push(@args,
+ 'config=s' => \$args->{config},
+ 'h|help' => \$args->{help},
+ 'v|verbose+' => \$args->{verbose}
+ );
+ GetOptions(@args);
+
+ if ($args->{help}) {
+ if (!@ARGV) {
+ # standard help, available immediatly
+ my $filename = (caller)[1];
+ pod2usage(
+ -input => $filename,
+ -verbose => 0
+ );
+ }
+ }
+
+ # config files parameters
+
+ # find configuration file to use
+ my $main_file;
+ if ($args->{config}) {
+ if (! -f $args->{config}) {
+ croak "Non-existing file $args->{config}";
+ } elsif (! -r $args->{config}) {
+ croak "Non-readable file $args->{config}";
+ } else {
+ $main_file = $args->{config};
+ }
+ } else {
+ foreach my $directory (@{$options{directories}}) {
+ my $file = "$directory/$options{file}";
+ next unless -f $file && -r $file;
+ $main_file = $file;
+ last;
+ }
+ croak 'No config file found, aborting' unless $main_file;
+ }
+
+ my $params;
+ eval {
+ $params = YAML::AppConfig->new(file => $main_file);
+ };
+ if ($@) {
+ croak "Invalid configuration file $main_file, aborting";
+ }
+
+ # process inclusions
+ my $includes = $params->get('includes');
+ if ($includes) {
+ foreach my $include_file (@{$includes}) {
+ # convert relative path to absolute ones
+ $include_file = File::Spec->rel2abs(
+ $include_file, (File::Spec->splitpath($main_file))[1]
+ );
+
+ if (! -f $include_file) {
+ warn "Non-existing file $include_file, skipping";
+ } elsif (! -r $include_file) {
+ warn "Non-readable file $include_file, skipping";
+ } else {
+ eval {
+ $params->merge(file => $include_file);
+ };
+ if ($@) {
+ carp "Invalid included configuration file $include_file, skipping";
+ }
+ }
+ }
+ }
+
+ my $self = bless {
+ _args => $args,
+ _params => $params
+ }, $class;
+
+ return $self;
+}
+
+sub get_arg {
+ my ($self, $arg) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_args}->{$arg};
+}
+
+sub get_param {
+ my ($self, $param) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_params}->get($param);
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Media/URPM.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Media/URPM.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Media/URPM.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,273 @@
+# $Id: URPM.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Media::URPM;
+
+=head1 NAME
+
+Youri::Media::URPM - URPM-based media implementation
+
+=head1 DESCRIPTION
+
+This is an URPM-based L<Youri::Media> implementation.
+
+It can be created either from local or remote full (hdlist) or partial
+(synthesis) compressed header files, or from a package directory. File-based
+inputs are only usable with this latest option.
+
+=cut
+
+use URPM;
+use File::Find;
+use File::Temp ();
+use Youri::Utils;
+use LWP::Simple;
+use Carp;
+use strict;
+use warnings;
+use Youri::Package::URPM;
+
+use base 'Youri::Media';
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Media::URPM object.
+
+Specific parameters:
+
+=over
+
+=item synthesis $synthesis
+
+Path, URL or list of path or URL of synthesis file used for creating
+this media. If a list is given, the first successfully accessed will be used,
+so as to allow better reliability.
+
+=item hdlist $hdlist
+
+Path, URL or list of path or URL of hdlist file used for creating
+this media. If a list is given, the first successfully accessed will be used,
+so as to allow better reliability.
+
+=item path $path
+
+Path or list of pathes of package directory used for creating this
+media. If a list is given, the first successfully accessed will be used, so as
+to allow better reliability.
+
+=item max_age $age
+
+Maximum age of packages for this media.
+
+=item rpmlint_config $file
+
+rpmlint configuration file for this media.
+
+=back
+
+In case of multiple B<synthesis>, B<hdlist> and B<path> options given, they
+will be tried in this order, so as to minimize parsing time.
+
+=cut
+
+sub _init {
+ my $self = shift;
+
+ my %options = (
+ hdlist => '', # hdlist from which to create this media
+ synthesis => '', # synthesis from which to create this media
+ path => '', # directory from which to create this media
+ max_age => '', # maximum build age for packages
+ rpmlint_config => '', # rpmlint configuration for packages
+ @_
+ );
+
+ my $urpm = URPM->new();
+ SOURCE: {
+ if ($options{synthesis}) {
+ foreach my $file (
+ ref $options{synthesis} eq 'ARRAY' ?
+ @{$options{synthesis}} :
+ $options{synthesis}
+ ) {
+ print "Attempting to retrieve synthesis $file\n"
+ if $options{verbose};
+ my $synthesis = $self->_get_file($file);
+ if ($synthesis) {
+ $urpm->parse_synthesis($synthesis, keep_all_tags => 1);
+ last SOURCE;
+ }
+ }
+ }
+
+ if ($options{hdlist}) {
+ foreach my $file (
+ ref $options{hdlist} eq 'ARRAY' ?
+ @{$options{hdlist}} :
+ $options{hdlist}
+ ) {
+ print "Attempting to retrieve hdlist $file\n"
+ if $options{verbose};
+ my $hdlist = $self->_get_file($file);
+ if ($hdlist) {
+ $urpm->parse_hdlist($hdlist, keep_all_tags => 1);
+ last SOURCE;
+ }
+ }
+ }
+
+ if ($options{path}) {
+ foreach my $path (
+ ref $options{path} eq 'ARRAY' ?
+ @{$options{path}} :
+ $options{path}
+ ) {
+ print "Attempting to scan directory $path\n"
+ if $options{verbose};
+ unless (-d $path) {
+ carp "non-existing directory $path";
+ next;
+ }
+ unless (-r $path) {
+ carp "non-readable directory $path";
+ next;
+ }
+
+ my $parse = sub {
+ return unless -f $File::Find::name;
+ return unless -r $File::Find::name;
+ return unless /\.rpm$/;
+
+ $urpm->parse_rpm($File::Find::name, keep_all_tags => 1);
+ };
+
+ find($parse, $path);
+ last SOURCE;
+ }
+ }
+
+ croak "no source specified";
+ }
+
+ $self->{_urpm} = $urpm;
+ $self->{_path} = $options{path};
+ $self->{_max_age} = $options{max_age};
+ $self->{_rpmlint_config} = $options{rpmlint_config};
+
+ return $self;
+}
+
+sub _remove_all_archs {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ $self->{_urpm}->{depslist} = [];
+}
+
+sub _remove_archs {
+ my ($self, $skip_archs) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $urpm = $self->{_urpm};
+ $urpm->{depslist} = [
+ grep { ! $skip_archs->{$_->arch()} } @{$urpm->{depslist}}
+ ];
+}
+
+=head1 INSTANCE METHODS
+
+=head2 max_age()
+
+Returns maximum age of packages for this media.
+
+=cut
+
+sub max_age {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_max_age};
+}
+
+=head2 rpmlint_config()
+
+Returns rpmlint configuration file for this media.
+
+=cut
+
+sub rpmlint_config {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_rpmlint_config};
+}
+
+sub get_package_class {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return "Youri::Package::URPM";
+}
+
+sub traverse_files {
+ my ($self, $function) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $callback = sub {
+ return unless -f $File::Find::name;
+ return unless -r $File::Find::name;
+ return unless $_ =~ /\.rpm$/;
+
+ my $package = Youri::Package::URPM->new(file => $File::Find::name);
+ return if $self->{_skip_archs}->{$package->get_arch()};
+
+ $function->($File::Find::name, $package);
+ };
+
+ find($callback, $self->{_path});
+}
+
+sub traverse_headers {
+ my ($self, $function) = @_;
+ croak "Not a class method" unless ref $self;
+
+ $self->{_urpm}->traverse(sub {
+ local $_; # workaround mysterious problem between URPM and AppConfig
+ $function->(Youri::Package::URPM->new(header => $_[0]));
+ });
+
+}
+
+sub _get_file {
+ my ($self, $file) = @_;
+
+ if ($file =~ /^(?:http|ftp):\/\/.*$/) {
+ my $tempfile = File::Temp->new();
+ my $status = getstore($file, $tempfile->filename());
+ unless (is_success($status)) {
+ carp "invalid URL $file: $status";
+ return;
+ }
+ return $tempfile;
+ } else {
+ unless (-f $file) {
+ carp "non-existing file $file";
+ return;
+ }
+ unless (-r $file) {
+ carp "non-readable file $file";
+ return;
+ }
+ return $file;
+ }
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Media.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Media.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Media.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,311 @@
+# $Id: Media.pm 1710 2006-10-16 16:35:11Z warly $
+package Youri::Media;
+
+=head1 NAME
+
+Youri::Media - Abstract media class
+
+=head1 DESCRIPTION
+
+This abstract class defines Youri::Media interface.
+
+=cut
+
+use Carp;
+use strict;
+use warnings;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Media object.
+
+Generic parameters:
+
+=over
+
+=item id $id
+
+Media id.
+
+=item name $name
+
+Media name.
+
+=item type $type (source/binary)
+
+Media type.
+
+=item test true/false
+
+Test mode (default: false).
+
+=item verbose true/false
+
+Verbose mode (default: false).
+
+=item allow_deps $media_ids
+
+list of ids of medias allowed to provide dependencies.
+
+=item skip_tests $test_ids
+
+list of ids of test plugins to skip.
+
+=item skip_archs $arches
+
+list of arches to skip.
+
+=back
+
+Subclass may define additional parameters.
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ name => '', # media name
+ canonical_name => '', # media canonical name
+ type => '', # media type
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ allow_deps => undef, # list of media ids from which deps are allowed
+ allow_srcs => undef, # list of media ids from which packages can be built
+ skip_tests => undef, # list of tests ids to skip
+ skip_archs => undef, # list of archs for which to skip tests
+ @_
+ );
+
+
+ croak "No type given" unless $options{type};
+ croak "Wrong value for type: $options{type}"
+ unless $options{type} =~ /^(?:binary|source)$/o;
+
+ # some options need to be arrays. Check it and convert to hashes
+ foreach my $option (qw(allow_deps allow_srcs skip_archs skip_tests)) {
+ next unless defined $options{$option};
+ croak "$option should be an arrayref" unless ref $options{$option} eq 'ARRAY';
+ $options{$option} = {
+ map { $_ => 1 } @{$options{$option}}
+ };
+ }
+
+ my $self = bless {
+ _id => $options{id},
+ _name => $options{name} || $options{id},
+ _type => $options{type},
+ _allow_deps => $options{allow_deps},
+ _allow_srcs => $options{allow_srcs},
+ _skip_archs => $options{skip_archs},
+ _skip_tests => $options{skip_tests},
+ }, $class;
+
+ $self->_init(%options);
+
+ # remove unwanted archs
+ if ($options{skip_archs}->{all}) {
+ $self->_remove_all_archs()
+ } elsif ($options{skip_archs}) {
+ $self->_remove_archs($options{skip_archs});
+ }
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+=head2 get_id()
+
+Returns media identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 get_name()
+
+Returns the name of this media.
+
+=cut
+
+sub get_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_name};
+}
+
+=head2 get_type()
+
+Returns the type of this media.
+
+=cut
+
+sub get_type {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_type};
+}
+
+=head2 allow_deps()
+
+Returns the list of id of medias allowed to provide dependencies for this
+media.
+
+=cut
+
+sub allow_deps {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return keys %{$self->{_allow_deps}};
+}
+
+=head2 allow_dep($media_id)
+
+Tells wether media with given id is allowed to provide dependencies for
+this media.
+
+=cut
+
+sub allow_dep {
+ my ($self, $dep) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_allow_deps}->{all} ||
+ $self->{_allow_deps}->{$dep};
+}
+
+=head2 allow_srcs()
+
+Returns the list medias where the source packages can be
+
+=cut
+
+sub allow_srcs {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return keys %{$self->{_allow_srcs}};
+}
+
+=head2 allow_src($media_id)
+
+Tells wether media with given id is allowed to host sources dependencies for
+this media.
+
+=cut
+
+sub allow_src {
+ my ($self, $src) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_allow_srcs}->{all} || $self->{_allow_srcs}->{$src};
+}
+
+=head2 skip_archs()
+
+Returns the list of arch which are to be skipped for this media.
+
+=cut
+
+sub skip_archs {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return keys %{$self->{_skip_archs}};
+}
+
+=head2 skip_arch($arch)
+
+Tells wether given arch is to be skipped for this media.
+
+=cut
+
+sub skip_arch {
+ my ($self, $arch) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_skip_archs}->{all} ||
+ $self->{_skip_archs}->{$arch};
+}
+
+=head2 skip_tests()
+
+Returns the list of id of test which are to be skipped for this media.
+
+=cut
+
+sub skip_tests {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return keys %{$self->{_skip_tests}};
+}
+
+=head2 skip_test($test_id)
+
+Tells wether test with given id is to be skipped for this media.
+
+=cut
+
+sub skip_test {
+ my ($self, $test) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_skip_tests}->{all} ||
+ $self->{_skip_tests}->{$test};
+}
+
+=head2 get_package_class()
+
+Return package class for this media.
+
+=head2 traverse_files($function)
+
+Apply given function to all files of this media.
+
+=head2 traverse_headers($function)
+
+Apply given function to all headers of this media.
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item traverse_headers
+
+=item traverse_files
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,58 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Package/URPM.pm 2257 2006-07-05T09:22:47.088572Z guillaume $
+package Youri::Package::RPM;
+
+=head1 NAME
+
+Youri::Package::RPM - Base class for all RPM-based package implementation
+
+=head1 DESCRIPTION
+
+This bases class factorize code between various RPM-based package
+implementation.
+
+=cut
+
+use strict;
+use warnings;
+use base 'Youri::Package';
+use Carp;
+
+sub get_pattern {
+ my ($class, $name, $version, $release, $arch) = @_;
+
+ return
+ ($name ? quotemeta($name) : '[\w-]+' ).
+ '-' .
+ ($version ? quotemeta($version) : '[^-]+' ).
+ '-' .
+ ($release ? quotemeta($release) : '[^-]+' ).
+ '\.' .
+ ($arch ? quotemeta($arch) : '\w+' ).
+ '\.rpm';
+}
+
+sub as_file {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_file};
+}
+
+sub is_debug {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name = $self->get_name();
+ my $group = $self->get_tag('group');
+
+ # debug packages' names must end in -debug, except kernel
+ if ($group =~ m,^Development/Debug$, &&
+ ($name =~ /-debug$/o || $name =~ /^kernel-.*-debug/o)) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM4.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM4.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Package/RPM4.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,424 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Package/URPM.pm 2129 2006-06-23T09:41:01.599329Z guillomovitch $
+package Youri::Package::RPM4;
+
+=head1 NAME
+
+Youri::Package::RPM4 - URPM-based rpm package implementation
+
+=head1 DESCRIPTION
+
+This is an RPM4-based L<Youri::Package> implementation for rpm.
+
+=cut
+
+use strict;
+use warnings;
+use Carp;
+use RPM4;
+use RPM4::Header;
+use RPM4::Sign;
+use File::Spec;
+use Scalar::Util qw/refaddr/;
+use base 'Youri::Package::RPM';
+use overload
+ '""' => 'as_string',
+ '0+' => '_to_number',
+ fallback => 1;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Package::RPM4 object.
+
+Specific parameters:
+
+=over
+
+=item file $file
+
+Path of file to use for creating this package.
+
+=item header $header
+
+L<RPM4::Header> object to use for creating this package.
+
+=back
+
+=cut
+
+sub _init {
+ my ($self, %options) = @_;
+
+ my $header;
+ HEADER: {
+ if (exists $options{header}) {
+ croak "undefined header"
+ unless $options{header};
+ croak "invalid header"
+ unless $options{header}->isa('RPM4::Header');
+ $header = $options{header};
+ last HEADER;
+ }
+
+ if (exists $options{file}) {
+ croak "undefined file"
+ unless $options{file};
+ croak "non-existing file $options{file}"
+ unless -f $options{file};
+ croak "non-readable file $options{file}"
+ unless -r $options{file};
+ $header = RPM4::Header->new($options{file});
+ croak "Can't get header from file $options{file}" if (!$header);
+
+ last HEADER;
+ }
+
+ croak "no way to extract header from arguments";
+ }
+
+ $self->{_header} = $header;
+ $self->{_file} = File::Spec->rel2abs($options{file});
+}
+
+sub compare_versions {
+ my ($class, $version1, $version2) = @_;
+
+ return RPM4::rpmvercmp($version1, $version2);
+}
+
+sub _depsense2flag {
+ my ($string) = @_;
+ my @flags = 0;
+ push(@flags, 'EQUAL') if ($string =~ /=/);
+ push(@flags, 'LESS') if ($string =~ /</);
+ push(@flags, 'GREATER') if ($string =~ />/);
+ return \@flags;
+}
+
+sub check_ranges_compatibility {
+ my ($class, $range1, $range2) = @_;
+ my @deps1 = split(/ /, $range1);
+ my @deps2 = split(/ /, $range2);
+ $deps1[1] = _depsense2flag($range1);
+ $deps2[1] = _depsense2flag($range2);
+ my $dep1 = RPM4::Header::Dependencies(
+ "PROVIDENAME",
+ \@deps1,
+ );
+ my $dep2 = RPM4::Header::Dependencies(
+ "PROVIDENAME",
+ \@deps2,
+ );
+
+ return $dep1->overlap($dep2);
+}
+
+sub get_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('name');
+}
+
+sub get_version {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('version');
+}
+
+sub get_release {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('release');
+}
+
+sub get_revision {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->queryformat('%|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}');
+}
+
+sub get_file_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->queryformat('%{NAME}-%{VERSION}-%{RELEASE}.%|SOURCERPM?{%{ARCH}}:{src}|.rpm');
+}
+
+
+sub get_arch {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->queryformat('%|SOURCERPM?{%{ARCH}}:{src}|');
+}
+
+sub get_url {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('url');
+}
+
+sub get_summary {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('summary');
+}
+
+sub get_description {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('description');
+}
+
+sub get_packager {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('packager');
+}
+
+sub is_source {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->issrc();
+}
+
+sub is_binary {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return !$self->{_header}->issrc();
+}
+
+sub get_type {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_header}->issrc() ?
+ "source" :
+ "binary";
+}
+
+sub get_age {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('buildtime');
+}
+
+sub get_source_package {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->tag('sourcerpm');
+}
+
+sub get_canonical_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ $self->{_header}->sourcerpmname() =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/;
+ return $1;
+}
+
+sub get_tag {
+ my ($self, $tag) = @_;
+ croak "Not a class method" unless ref $self;
+ #croak "invalid tag $tag" unless $self->{_header}->can($tag);
+ return $self->{_header}->tag($tag);
+}
+
+
+sub _get_dependencies {
+ my ($self, $deptype) = @_;
+ my $deps = $self->{_header}->dep($deptype);
+ my @deps_list;
+ if ($deps) {
+ $deps->init();
+ while ($deps->next() >= 0) {
+ my @deps = $deps->info();
+ $deps[1] =~ m/^rpmlib\(/ and next; # skipping internal rpmlib dep
+ $deps[2] =~ s/^=$/==/; # rpm say foo = 1, not foo == 1, == come from URPM, which sucks
+ my $range = $deps[3] ? ($deps[2] . ' ' . $deps[3]) : undef;
+ push(@deps_list, [ $deps[1], $range ]);
+ }
+ }
+ @deps_list
+}
+
+sub get_requires {
+ my ($self) = @_;
+
+ return $self->_get_dependencies('REQUIRENAME');
+}
+
+sub get_provides {
+ my ($self) = @_;
+
+ return $self->_get_dependencies('PROVIDENAME');
+}
+
+sub get_obsoletes {
+ my ($self) = @_;
+
+ return $self->_get_dependencies('OBSOLETENAME');
+}
+
+sub get_conflicts {
+ my ($self) = @_;
+
+ return $self->_get_dependencies('CONFLICTNAME');
+}
+
+sub get_files {
+ my ($self) = @_;
+
+ my $files = $self->{_header}->files();
+ my @fileslist;
+ if ($files) {
+ $files->init();
+ while ($files->next() >= 0) {
+ my $smode = $files->mode();
+ my $umode = 0;
+ foreach (0..15) { # converting unsigned to signed int :\
+ $umode |= $smode & (1 << $_);
+ }
+ push(@fileslist, [ $files->filename(), $umode, $files->md5() || '' ]);
+ }
+ }
+ @fileslist
+}
+
+sub get_gpg_key {
+ my ($self) = @_;
+
+ my $signature = $self->{_header}->queryformat('%{SIGGPG:pgpsig}');
+
+ return if $signature eq '(not a blob)';
+
+ my $key_id = (split(/\s+/, $signature))[-1];
+
+ return substr($key_id, 8);
+}
+
+sub get_information {
+ my ($self) = @_;
+
+ return $self->{_header}->queryformat(<<EOF);
+Name : %-27{NAME} Relocations: %|PREFIXES?{[%{PREFIXES} ]}:{(not relocatable)}|
+Version : %-27{VERSION} Vendor: %{VENDOR}
+Release : %-27{RELEASE} Build Date: %{BUILDTIME:date}
+Install Date: %|INSTALLTIME?{%-27{INSTALLTIME:date}}:{(not installed) }| Build Host: %{BUILDHOST}
+Group : %-27{GROUP} Source RPM: %{SOURCERPM}
+Size : %-27{SIZE}%|LICENSE?{ License: %{LICENSE}}|
+Signature : %|DSAHEADER?{%{DSAHEADER:pgpsig}}:{%|RSAHEADER?{%{RSAHEADER:pgpsig}}:{%|SIGGPG?{%{SIGGPG:pgpsig}}:{%|SIGPGP?{%{SIGPGP:pgpsig}}:{(none)}|}|}|}|
+%|PACKAGER?{Packager : %{PACKAGER}\n}|%|URL?{URL : %{URL}\n}|Summary : %{SUMMARY}
+Description :\n%{DESCRIPTION}
+EOF
+}
+
+sub get_changes {
+ my ($self) = @_;
+
+ my @names = $self->{_header}->tag('changelogname');
+ my @time = $self->{_header}->tag('changelogtime');
+ my @text = $self->{_header}->tag('changelogtext');
+
+ my @changes;
+ foreach my $i (0 .. $#names) {
+ $changes[$i] = [
+ $names[$i],
+ $time[$i],
+ $text[$i],
+ ];
+ }
+
+ return @changes;
+}
+
+sub get_last_change {
+ my ($self) = @_;
+
+ return [
+ ($self->{_header}->tag('changelogname'))[0],
+ ($self->{_header}->tag('changelogtime'))[0],
+ ($self->{_header}->tag('changelogtext'))[0],
+ ];
+}
+
+sub as_string {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->fullname();
+}
+
+sub as_formated_string {
+ my ($self, $format) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->queryformat($format);
+}
+
+sub _to_number {
+ return refaddr($_[0]);
+}
+
+sub compare {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->compare($package->{_header}) || 0;
+}
+
+sub satisfy_range {
+ my ($self, $range) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->check_range_compatibility($self->get_revision(), $range);
+}
+
+sub sign {
+ my ($self, $name, $path, $passphrase) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # check if parent directory is writable
+ my $parent = (File::Spec->splitpath($self->{_file}))[1];
+ croak "Unsignable package, parent directory is read-only"
+ unless -w $parent;
+
+ my $sign = RPM4::Sign->new(
+ name => $name,
+ path => $path,
+ );
+ $sign->{passphrase} = $passphrase;
+
+ $sign->rpmssign($self->{_file})
+}
+
+sub extract {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ system("rpm2cpio $self->{_file} | cpio -id >/dev/null 2>&1");
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Package/Test.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Package/Test.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Package/Test.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,151 @@
+# $Id: /local/youri/soft/core/trunk/lib/Youri/Package/URPM.pm 2133 2006-09-20T21:40:20.575763Z guillaume $
+package Youri::Package::Test;
+
+=head1 NAME
+
+Youri::Package::Test - Fake test package
+
+=head1 DESCRIPTION
+
+This is just a fake package object, intended for testing purposes.
+
+=cut
+
+use strict;
+use warnings;
+use Carp;
+use base 'Youri::Package::RPM';
+use overload
+ '""' => 'as_string',
+ '0+' => '_to_number',
+ fallback => 1;
+
+our $AUTOLOAD;
+
+my @tags = qw/
+ name
+ version
+ release
+ filename
+ arch
+ url
+ summary
+ description
+ packager
+ buildtime
+ sourcerpm
+/;
+
+my %tags = map { $_ => 1 } @tags;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Package::Test object.
+
+Specific parameters:
+
+=over
+
+=item tag $tag
+
+Use given value for given tag
+
+=back
+
+=cut
+
+sub _init {
+ my ($self, %options) = @_;
+
+ $self->{"_$_"} = $options{$_} foreach keys %options;
+}
+
+sub get_revision {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_epoch} ?
+ "$self->{_epoch}:$self->{_version}-$self->{_release}" :
+ "$self->{_version}-$self->{_release}";
+}
+
+sub get_tag {
+ my ($self, $tag) = @_;
+ croak "Not a class method" unless ref $self;
+ croak "invalid tag $tag" unless $tags{$tag};
+ return $self->{'_' . $tag};
+}
+
+sub is_source {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_arch} eq 'src';
+}
+
+sub is_binary {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_arch} ne 'src';
+}
+
+sub get_type {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_arch} eq 'src' ?
+ "source" :
+ "binary";
+}
+
+sub get_canonical_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ if ($self->{_arch} eq 'src') {
+ return $self->{_name};
+ } else {
+ if ($self->{_sourcerpm}) {
+ $self->{_sourcerpm} =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/;
+ return $1;
+ } else {
+ return undef;
+ }
+ }
+}
+
+sub as_string {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_name} ? $self->{_name} : '' .
+ '-' .
+ $self->{_version} ? $self->{_version} : '' .
+ '-' .
+ $self->{_release} ? $self->{_release} : '';
+}
+
+sub _to_number {
+ return refaddr($_[0]);
+}
+
+sub AUTOLOAD {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $method = $AUTOLOAD;
+ $method =~ s/.*:://;
+ return if $method eq 'DESTROY';
+ croak "invalid method" unless $method =~ /^get_(\w+)$/;
+
+ my $tag = $1;
+ croak "invalid tag $tag" unless $tags{$tag};
+ return $self->{'_' . $tag};
+}
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Package/URPM.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Package/URPM.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Package/URPM.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,399 @@
+# $Id: URPM.pm 266577 2010-03-02 14:51:24Z bogdano $
+package Youri::Package::URPM;
+
+=head1 NAME
+
+Youri::Package::URPM - URPM-based rpm package implementation
+
+=head1 DESCRIPTION
+
+This is an URPM-based L<Youri::Package> implementation for rpm.
+
+It is merely a wrapper over URPM::Package class, with a more structured
+interface.
+
+=cut
+
+use strict;
+use warnings;
+use Carp;
+use URPM;
+use File::Spec;
+use Expect;
+use Scalar::Util qw/refaddr/;
+use base 'Youri::Package::RPM';
+use overload
+ '""' => 'as_string',
+ '0+' => '_to_number',
+ fallback => 1;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Package::URPM object.
+
+Specific parameters:
+
+=over
+
+=item file $file
+
+Path of file to use for creating this package.
+
+=item header $header
+
+L<URPM::Package> object to use for creating this package.
+
+=back
+
+=cut
+
+sub _init {
+ my ($self, %options) = @_;
+
+ my $header;
+ HEADER: {
+ if (exists $options{header}) {
+ croak "undefined header"
+ unless $options{header};
+ croak "invalid header"
+ unless $options{header}->isa('URPM::Package');
+ $header = $options{header};
+ last HEADER;
+ }
+
+ if (exists $options{file}) {
+ croak "undefined file"
+ unless $options{file};
+ croak "non-existing file $options{file}"
+ unless -f $options{file};
+ croak "non-readable file $options{file}"
+ unless -r $options{file};
+ my $urpm = URPM->new();
+ $urpm->parse_rpm($options{file}, keep_all_tags => 1);
+ $header = $urpm->{depslist}->[0];
+ croak "non-rpm file $options{file}" unless $header;
+ last HEADER;
+ }
+
+ croak "no way to extract header from arguments";
+ }
+
+ $self->{_header} = $header;
+ $self->{_file} = File::Spec->rel2abs($options{file});
+}
+
+sub compare_versions {
+ my ($class, $version1, $version2) = @_;
+
+ return URPM::rpmvercmp($version1, $version2);
+}
+
+sub check_ranges_compatibility {
+ my ($class, $range1, $range2) = @_;
+
+ return URPM::ranges_overlap($range1, $range2);
+}
+
+sub get_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->name();
+}
+
+sub get_version {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->version();
+}
+
+sub get_release {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->release();
+}
+
+sub get_revision {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->queryformat('%|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}');
+}
+
+sub get_file_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_file} || die "_file is not defined in header-only objects!\n";
+}
+
+sub get_arch {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->arch();
+}
+
+sub get_url {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->url();
+}
+
+sub get_summary {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->summary();
+}
+
+sub get_description {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->description();
+}
+
+sub get_packager {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->packager();
+}
+
+sub is_source {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->arch() eq 'src';
+}
+
+sub is_binary {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->arch() ne 'src';
+}
+
+sub get_type {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_header}->arch() eq 'src' ?
+ "source" :
+ "binary";
+}
+
+sub get_age {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->buildtime();
+}
+
+sub get_source_package {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->sourcerpm();
+}
+
+sub get_canonical_name {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ if ($self->{_header}->arch() eq 'src') {
+ return $self->{_header}->name();
+ } else {
+ $self->{_header}->sourcerpm() =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/;
+ return $1;
+ }
+}
+
+sub get_tag {
+ my ($self, $tag) = @_;
+ croak "Not a class method" unless ref $self;
+ croak "invalid tag $tag" unless $self->{_header}->can($tag);
+ return $self->{_header}->$tag();
+}
+
+sub get_requires {
+ my ($self) = @_;
+
+ return map {
+ $_ =~ /^([^[]+)(?:\[\*\])?(?:\[(.+)\])?$/;
+ [ $1, $2 ]
+ } $self->{_header}->requires();
+}
+
+sub get_provides {
+ my ($self) = @_;
+
+ return map {
+ $_ =~ /^([^[]+)(?:\[(.+)\])?$/;
+ [ $1, $2 && $2 ne '*' ? $2 : undef ]
+ } $self->{_header}->provides();
+}
+
+sub get_obsoletes {
+ my ($self) = @_;
+
+ return map {
+ $_ =~ /^([^[]+)(?:\[(.+)\])?$/;
+ [ $1, $2 && $2 ne '*' ? $2 : undef ]
+ } $self->{_header}->obsoletes();
+}
+
+sub get_conflicts {
+ my ($self) = @_;
+
+ return $self->{_header}->conflicts();
+}
+
+sub get_files {
+ my ($self) = @_;
+
+ my @modes = $self->{_header}->files_mode();
+ my @md5sums = $self->{_header}->files_md5sum();
+
+ return map {
+ [ $_, shift @modes, shift @md5sums ]
+ } $self->{_header}->files();
+}
+
+sub get_gpg_key {
+ my ($self) = @_;
+
+ my $signature = $self->{_header}->queryformat('%{SIGGPG:pgpsig}');
+
+ return if $signature eq '(not a blob)';
+
+ my $key_id = (split(/\s+/, $signature))[-1];
+
+ return substr($key_id, 8);
+}
+
+sub get_information {
+ my ($self) = @_;
+
+ return $self->{_header}->queryformat(<<EOF);
+Name : %-27{NAME} Relocations: %|PREFIXES?{[%{PREFIXES} ]}:{(not relocatable)}|
+Version : %-27{VERSION} Vendor: %{VENDOR}
+Release : %-27{RELEASE} Build Date: %{BUILDTIME:date}
+Install Date: %|INSTALLTIME?{%-27{INSTALLTIME:date}}:{(not installed) }| Build Host: %{BUILDHOST}
+Group : %-27{GROUP} Source RPM: %{SOURCERPM}
+Size : %-27{SIZE}%|LICENSE?{ License: %{LICENSE}}|
+Signature : %|DSAHEADER?{%{DSAHEADER:pgpsig}}:{%|RSAHEADER?{%{RSAHEADER:pgpsig}}:{%|SIGGPG?{%{SIGGPG:pgpsig}}:{%|SIGPGP?{%{SIGPGP:pgpsig}}:{(none)}|}|}|}|
+%|PACKAGER?{Packager : %{PACKAGER}\n}|%|URL?{URL : %{URL}\n}|Summary : %{SUMMARY}
+Description :\n%{DESCRIPTION}
+EOF
+}
+
+sub get_changes {
+ my ($self) = @_;
+
+ my @names = $self->{_header}->changelog_name();
+ my @time = $self->{_header}->changelog_time();
+ my @text = $self->{_header}->changelog_text();
+
+ my @changes;
+ foreach my $i (0 .. $#names) {
+ $changes[$i] = [
+ $names[$i],
+ $time[$i],
+ $text[$i],
+ ];
+ }
+
+ return @changes;
+}
+
+sub get_last_change {
+ my ($self) = @_;
+
+ return [
+ ($self->{_header}->changelog_name())[0],
+ ($self->{_header}->changelog_time())[0],
+ ($self->{_header}->changelog_text())[0],
+ ];
+}
+
+sub as_string {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->fullname();
+}
+
+sub as_formated_string {
+ my ($self, $format) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->queryformat($format);
+}
+
+sub _to_number {
+ return refaddr($_[0]);
+}
+
+sub compare {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_header}->compare_pkg($package->{_header});
+}
+
+sub satisfy_range {
+ my ($self, $range) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->check_ranges_compatibility("== " . $self->get_revision(), $range);
+}
+
+sub sign {
+ my ($self, $name, $path, $passphrase, $target) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # check if parent directory is writable
+ my $parent = (File::Spec->splitpath($self->{_file}))[1];
+ croak "Unsignable package, parent directory is read-only"
+ unless -w $parent;
+
+ # FIXME Will have to change that
+ # we sign with cooker key even fro 2007.0 because this is for testing section
+ return !system("sudo -H /root/bin/resign_cooker $self->{_file}");
+
+ my $command =
+ 'LC_ALL=C rpm --resign ' . $self->{_file} .
+ ' --define "_gpg_name ' . $name . '"' .
+ ' --define "_gpg_path ' . $path . '"';
+ my $expect = Expect->spawn($command) or die "Couldn't spawn command $command: $!\n";
+ $expect->log_stdout(0);
+ $expect->expect(20, -re => 'Enter pass phrase:');
+ $expect->send("$passphrase\n");
+
+ $expect->soft_close();
+}
+
+sub extract {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ system("rpm2cpio $self->{_file} | cpio -id >/dev/null 2>&1");
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Package.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Package.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Package.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,336 @@
+# $Id: Package.pm 223952 2007-06-23 13:54:13Z pixel $
+package Youri::Package;
+
+=head1 NAME
+
+Youri::Package - Abstract package class
+
+=head1 DESCRIPTION
+
+This abstract class defines Youri::Package interface.
+
+=cut
+
+use Carp;
+use strict;
+use warnings;
+
+use constant DEPENDENCY_NAME => 0;
+use constant DEPENDENCY_RANGE => 1;
+
+use constant FILE_NAME => 0;
+use constant FILE_MODE => 1;
+use constant FILE_MD5SUM => 2;
+
+use constant CHANGE_AUTHOR => 0;
+use constant CHANGE_TIME => 1;
+use constant CHANGE_TEXT => 2;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Package object.
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ @_
+ );
+
+ my $self = bless {
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head2 get_pattern($name, $version, $release, $arch)
+
+Returns a pattern matching a file for a package, using available informations.
+
+=head2 compare_revisions($revision1, $revision2)
+
+Compares two revision tokens, and returns a numeric value:
+
+=over
+
+=item positive if first revision is higher
+
+=item null if both revisions are equal
+
+=item negative if first revision is lower
+
+=back
+
+=head2 check_ranges_compatibility($range1, $range2)
+
+Returns a true value if given revision ranges are compatible.
+
+=head1 INSTANCE METHODS
+
+=head2 as_file()
+
+Returns the file corresponding to this package.
+
+=head2 as_string()
+
+Returns a string representation of this package.
+
+=head2 as_formated_string(I<format>)
+
+Returns a string representation of this package, formated according to
+I<format>. Format is a string, where each %{foo} token will get replaced by
+equivalent tag value.
+
+=head2 get_name()
+
+Returns the name of this package.
+
+=head2 get_version()
+
+Returns the version of this package.
+
+=head2 get_release()
+
+Returns the release of this package.
+
+=head2 get_revision()
+
+Returns the revision of this package.
+
+=head2 get_arch()
+
+Returns the architecture of this package.
+
+=head2 get_file_name()
+
+Returns the file name of this package (name-version-release.arch.extension).
+
+=head2 is_source()
+
+Returns true if this package is a source package.
+
+=head2 is_binary()
+
+Returns true if this package is a binary package.
+
+=head2 is_debug()
+
+Returns true if this package is a debug package.
+
+=head2 get_type()
+
+Returns the type (binary/source) of this package.
+
+=head2 get_age()
+
+Returns the age of this package
+
+=head2 get_url()
+
+Returns the URL of this package
+
+=head2 get_summary()
+
+Returns the summary of this package
+
+=head2 get_description()
+
+Returns the description of this package
+
+=head2 get_packager()
+
+Returns the packager of this package.
+
+=head2 get_source_package()
+
+Returns the name of the source package of this package.
+
+=head2 get_tag($tag)
+
+Returns the value of tag $tag of this package.
+
+=head2 get_canonical_name()
+
+Returns the canonical name of this package, shared by its multiple components,
+usually the one from the source package.
+
+=head2 get_requires()
+
+Returns the list of dependencies required by this package, each dependency
+being represented as an array reference, with the following informations:
+
+=over
+
+=item B<name>
+
+Name of the dependency (index DEPENDENCY_NAME)
+
+=item B<range>
+
+Range of the dependency (index DEPENDENCY_RANGE)
+
+=back
+
+For more conveniency, fields index are available as constant in this package.
+
+=head2 get_provides()
+
+Returns the list of dependencies provided by this package, each dependency
+being represented as an array reference, using the same structure as previous method.
+
+=head2 get_obsoletes()
+
+Returns the list of other packages obsoleted by this one, each one
+being represented as an array reference, using the same structure as previous method.
+
+=head2 get_conflicts()
+
+Returns the list of other packages conflicting with this one.
+
+=head2 get_files()
+
+Returns the list of files contained in this package, each file being
+represented as an array reference, with the following informations:
+
+=over
+
+=item B<name>
+
+Name of the file (index FILE_NAME).
+
+=item B<mode>
+
+Mode of the file (index FILE_MODE).
+
+=item B<md5sum>
+
+Md5sum of the file (index FILE_MD5SUM).
+
+=back
+
+For more conveniency, fields index are available as constant in this package.
+
+=head2 get_gpg_key()
+
+Returns the gpg key id of package signature.
+
+=head2 get_information()
+
+Returns formated informations about the package.
+
+=head2 get_changes()
+
+Returns the list of changes for this package, each change being
+represented as an array reference, with the following informations:
+
+=over
+
+=item B<author>
+
+Author of the change (index CHANGE_AUTHOR).
+
+=item B<time>
+
+Time of the change (index CHANGE_TIME).
+
+=item B<text>
+
+Raw textual description of the change (index CHANGE_TEXT).
+
+=back
+
+For more conveniency, fields index are available as constant in this package.
+
+=head2 get_last_change()
+
+Returns the last change for this package, as as structure described before.
+
+=head2 compare($package)
+
+Compares ordering with other package, according to their corresponding revision
+tokens, and returns a numeric value:
+
+=over
+
+=item positive if this package is newer
+
+=item null if both have same revision
+
+=item negative if this package is older
+
+=back
+
+=head2 satisfy_range($range)
+
+Returns a true value if this package revision satisfies given revision range.
+
+=head2 sign($name, $path, $passphrase)
+
+Signs the package with given name, keyring path and passphrase.
+
+=head2 extract()
+
+Extract package content in local directory.
+
+=head1 SUBCLASSING
+
+All instances methods have to be implemented.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+sub get_file {
+ my ($self) = @_;
+ carp "Deprecated method, use as_file now";
+
+ return $self->as_file();
+}
+
+sub get_full_name {
+ my ($self) = @_;
+ carp "Deprecated method, use as_string now";
+
+ return $self->as_string();
+}
+
+sub compare_versions {
+ my ($self, $version1, $version2) = @_;
+ carp "Deprecated method, use compare_revisions now";
+
+ return $self->compare_revisions($version1, $version2);
+}
+
+sub compare_ranges {
+ my ($self, $range1, $range2) = @_;
+ carp "Deprecated method, use are_range_compatible now";
+
+ return $self->check_ranges_compatibility($range1, $range2);
+}
+
+sub get_revision_name {
+ my ($self) = @_;
+ carp "Deprecated method, use as_formated_string('%name-%version-%release') now";
+
+ return $self->as_formated_string('%{name}-%{version}-%{release}');
+}
+
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,546 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Upload/Action/RSS.pm 857 2006-01-29T10:15:43.298856Z guillaume $
+package Youri::Repository::Mandriva_upload;
+
+=head1 NAME
+
+Youri::Repository::PLF - PLF repository implementation
+
+=head1 DESCRIPTION
+
+This module implements PLF repository.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use Memoize;
+use File::Find 'find';
+use base qw/Youri::Repository/;
+use MDV::Distribconf::Build;
+use SVN::Client;
+
+use constant {
+ PACKAGE_CLASS => 'Youri::Package::URPM',
+ PACKAGE_CHARSET => 'utf8'
+};
+
+memoize('_get_media_config');
+
+my %translate_arch = (
+ i386 => 'i586',
+ sparc64 => 'sparcv9',
+);
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ noarch => 'i586', # noarch packages policy
+ src => 'i586',
+ install_root => '',
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ queue => '',
+ rejected => '',
+ @_
+ );
+ foreach my $var ('upload_state') {
+ $self->{"_$var"} = [];
+ foreach my $value (split ' ', $options{$var}) {
+ push @{$self->{"_$var"}}, $value
+ }
+ }
+ print "Initializing repository\n";
+ foreach my $v ('rejected', 'svn', 'queue', 'noarch', 'install_root', 'upload_root', 'verbose') {
+ $self->{"_$v"} = $options{$v}
+ }
+ foreach my $target (@{$options{targets}}) {
+ $self->{$target} = [];
+ print "Adding $target ($options{$target}{arch})\n" if $self->{_verbose};
+ foreach my $value (split ' ', $options{$target}{arch}) {
+ push @{$self->{_arch}{$target}}, $value;
+ push @{$self->{_extra_arches}}, $value
+ }
+ }
+ $self
+}
+
+sub get_group_id {
+ my ($user) = @_;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
+ $year+=1900;
+ $mon++;
+ my $hostname = `hostname`;
+ my ($host) = $hostname =~ /([^.]*)/;
+ sprintf "$year%02d%02d%02d%02d%02d.$user.$host.${$}_", $mon, $mday, $hour, $min, $sec;
+}
+
+sub get_target_arch {
+ my ($self, $target) = $_;
+ return $self->{_arch}{$target}
+}
+
+sub set_arch_changed {
+ my ($self, $target, $arch) = @_;
+ if ($arch eq 'noarch') {
+ $self->{_arch_changed}{$_} = 1 foreach @{$self->{_arch}{$target}}
+ } elsif ($arch eq 'src') {
+ $self->{_arch_changed} = $self->{_src}
+ } else {
+ $self->{_arch_changed}{$arch} = 1
+ }
+}
+
+sub get_arch_changed {
+ my ($self, $target) = @_;
+ return [ keys %{$self->{_arch_changed}} ]
+}
+
+sub set_install_dir_changed {
+ my ($self, $install_dir) = @_;
+ $self->{_install_dir_changed}{$install_dir} = 1;
+}
+
+sub get_install_dir_changed {
+ my ($self) = @_;
+ return [ keys %{$self->{_install_dir_changed}} ];
+}
+
+sub _get_media_config {
+ my ($self, $target) = @_;
+ my %media;
+ my $real_target = $target;
+ $real_target =~ s/_force//;
+ foreach my $arch (@{$self->{_arch}{$target}}) {
+ my $root = "$self->{_install_root}/$real_target/$arch";
+ my $distrib = MDV::Distribconf::Build->new($root);
+ print "Getting media config from $root\n" if $self->{_verbose};
+ $self->{distrib}{$arch} = $distrib;
+ $distrib->loadtree or die "$root does not seem to be a distribution tree\n";
+ $distrib->parse_mediacfg;
+ foreach my $media ($distrib->listmedia) {
+ my $rpms = $distrib->getvalue($media, 'rpms');
+ my $debug_for = $distrib->getvalue($media, 'debug_for');
+ my $srpms = $distrib->getvalue($media, 'srpms');
+ my $path = $distrib->getfullpath($media, 'path');
+ if (!$rpms) {
+ if (-d $path) {
+ print "MEDIA defining $media in $path\n" if $self->{_verbose} > 1;
+ $media{$arch}{$media} = $path
+ } else {
+ print "ERROR $path does not exist for media $media on $arch\n"
+ }
+ } else {
+ my ($media) = split ' ', $rpms;
+ if (-d $path) {
+ print "MEDIA defining SOURCE media for $media in $path\n" if $self->{_verbose} > 1;
+ $media{src}{$media} = $path
+ } else {
+ print "ERROR $path does not exist for source media $media on $arch\n"
+ }
+ }
+ }
+ }
+ \%media
+}
+
+sub get_package_class {
+ return PACKAGE_CLASS;
+}
+
+sub get_package_charset {
+ return PACKAGE_CHARSET;
+}
+
+sub get_upload_dir {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ return
+ $self->{_upload_root} .
+ "/$self->{_queue}/$target/" .
+ _get_section($self, $package, $target, $user_context, $app_context) .
+ '/' .
+ ($user_context->{prefix} ? '' : get_group_id($user_context->{user}))
+}
+
+sub get_install_path {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ return $self->_get_path($package, $target, $user_context, $app_context);
+}
+
+
+sub get_distribution_paths {
+ my ($self, $package, $target) = @_;
+
+ return $self->_get_distribution_paths($package, $target);
+}
+
+sub get_archive_path {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ return $self->_get_path($package, $target, $user_context, $app_context);
+}
+
+sub get_reject_path {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ return $self->{_rejected};
+}
+
+
+sub _get_path {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ my $section = $self->_get_section($package, $target, $user_context, $app_context);
+ my $arch = $app_context->{arch} || $package->get_arch();
+ $arch = $translate_arch{$arch} || $arch;
+ if ($arch eq 'noarch') {
+ $arch = $self->{_noarch}
+ } elsif ($arch eq 'src') {
+ return "$target/SRPMS/$section"
+ }
+ "$target/$arch/media/$section"
+}
+
+sub _get_distribution_paths {
+ my ($self, $package, $target) = @_;
+
+ my $arch = $package->get_arch();
+ $arch = $translate_arch{$arch} || $arch;
+ if ($arch eq 'noarch') {
+ map { "$target/$_" } $self->get_extra_arches;
+ } elsif ($arch eq 'src') {
+ die "no way to get distribution path using a $arch package";
+ } else {
+ "$target/$arch";
+ }
+}
+
+sub get_arch {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ my $arch = $package->get_arch();
+ $arch = $translate_arch{$arch} || $arch;
+ if ($arch eq 'noarch') {
+ $arch = $self->{_noarch}
+ }
+ $arch
+}
+
+sub get_version_path {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ my $section = $self->_get_section($package, $target, $user_context, $app_context);
+
+ return "$self->{_module}/$section";
+}
+
+=head2 get_replaced_packages($package, $target, $user_context, $app_context)
+
+Overrides parent method to add libified packages.
+
+=cut
+
+sub get_replaced_packages {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my @replaced_packages =
+ $self->SUPER::get_replaced_packages($package, $target, $user_context, $app_context);
+
+ # mandriva lib policy:
+ # library package names change with revision, making mandatory to
+ # duplicate older revisions search with a custom pattern
+ my $name = $package->get_name();
+ if ($name =~ /^(lib\w+[a-zA-Z_])[\d_\.]+([-\w]*)$/) {
+ push(@replaced_packages,
+ grep { $package->compare($_) > 0 }
+ map { PACKAGE_CLASS->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ $self->get_install_path($package, $target, $user_context, $app_context),
+ PACKAGE_CLASS->get_pattern(
+ $1 . '[\d_\.]+' . $2, # custom name pattern
+ undef,
+ undef,
+ $package->get_arch()
+ ),
+ )
+ );
+ }
+
+ # kernel packages have the version in the name
+ # binary dkms built for old kernels have to be removed too
+ if ($name =~ /^kernel-([^\d]*-)?([\d.]*)-(.*)$/) { # "desktop", "2.6.28", "2mnb"
+ push(@replaced_packages,
+ map { PACKAGE_CLASS->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ $self->get_install_path($package, $target, $user_context, $app_context),
+ PACKAGE_CLASS->get_pattern(
+ '(kernel-' . $1 . '\d.*|.*-kernel-[\d.]*-' . $1 . '\d.*)',
+ undef,
+ undef,
+ $package->get_arch()
+ ),
+ )
+ );
+ }
+
+ return @replaced_packages;
+
+}
+
+sub _get_main_section {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ my $section = $self->_get_section($package, $target, $user_context, $app_context);
+ my ($main_section) = $section =~ m,^([^/]+),;
+ $main_section
+}
+
+sub _get_section {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+
+ my $name = $package->get_name();
+ my $cname = $package->get_canonical_name();
+ my $version = $package->get_version();
+ my $release = $package->get_release();
+ my $section = $user_context->{section};
+ my $media = $self->_get_media_config($target);
+ my $arch = $package->get_arch();
+ my $file = $package->as_file();
+ $file =~ s,/+,/,g; # unneeded?
+ # FIXME: use $self->get_arch()
+ $arch = $self->{_noarch} if $arch eq 'noarch';
+ $arch = $translate_arch{$arch} || $arch;
+
+ if (!$section) {
+ $section = $self->{packages}{$file}{section};
+ print "Section undefined, repository says it is '$section' for '$file'\n" if $self->{_verbose};
+ }
+ if ($section && $section !~ /debug_/ && $package->is_debug()) {
+ $section = "debug_$section"
+ }
+
+ # if have section already, check if it exists, and may return immediately
+ if ($section) {
+ print "Using requested section $section\n";
+ if ($media->{$arch}{$section}) {
+ return $section
+ } else {
+ die "FATAL youri: unknown section $section for target $target for arch $arch\n"
+ }
+ }
+ # else, try to find section automatically
+
+ # pattern for search of src package with specific version-release,
+ # should be searched first, because we prefer to find the precise
+ # section a package is already in
+ my $specific_source_pattern = PACKAGE_CLASS->get_pattern(
+ $cname,
+ $version,
+ $release,
+ 'src'
+ );
+
+ my $source_pattern = PACKAGE_CLASS->get_pattern(
+ $cname,
+ undef,
+ undef,
+ 'src'
+ );
+
+ # if a media has no source media configured, or if it is a debug
+ # package, we search in binary media
+
+ # pattern for search when a binary media has no src media configured
+ my $specific_binary_pattern = PACKAGE_CLASS->get_pattern(
+ $name,
+ $version,
+ $release,
+ $arch
+ );
+
+ # last resort pattern: previous existing binary packages
+ my $binary_pattern = PACKAGE_CLASS->get_pattern(
+ $name,
+ undef,
+ undef,
+ $arch
+ );
+
+ # first try to find section for the specific version, as it is possibly already there;
+ # this is the case for when called in Youri::Submit::Action::Archive, to find the
+ # section the package got installed
+ print "Looking for package $name with version $version-$release\n";
+ foreach my $m (keys %{$media->{$arch}}) {
+ print " .. section '$m' path '".$media->{$arch}{$m}."'\n" if $self->{_verbose};
+ # - prefer source for non-debug packages, use binary if there is no source media configured
+ # - debug packages must be searched in binary medias, due to their
+ # src section != binary section; NOTE: should/need we search in
+ # src medias and add the 'debug_' prefix?
+ if (!$package->is_debug() && $media->{src}{$m}) {
+ next unless $self->get_files('', $media->{src}{$m}, $specific_source_pattern);
+ } else {
+ next unless $self->get_files('', $media->{$arch}{$m}, $specific_binary_pattern);
+ }
+ $section = $m;
+ last;
+ }
+
+ # if still not found, try finding any version of the package in a
+ # /release subsection (safe default: /release is default for cooker,
+ # should be locked for released distros, and we don't risk wrongly
+ # choosing /backports, /testing, or /updates);
+ # this is the case for when called at submit, to find the section where
+ # the package already resides
+ if (!$section) {
+ # debug packages should be found by previous specific version search
+ # NOTE: as above, should/need we search here and add the 'debug_' prefix?
+ # ... probably... as at least mdv-youri-submit-force will process debug packages
+ if ($package->is_debug() && $self->{_verbose}) {
+ print "Warning: debug package $name with version $version-$release not found.\n";
+ }
+
+ print "Warning: Looking for any section with a package $name of any version\n";
+ foreach my $m (keys %{$media->{$arch}}) {
+ print " .. section '$m' path '".$media->{$arch}{$m}."'\n" if $self->{_verbose};
+ # NOTE: !$package->is_debug() test is here to prevent when above FATAL error is removed
+ next if $m !~ /release/ || ($m =~ /debug/ && !$package->is_debug());
+ # - prefer source
+ if ($media->{src}{$m}) {
+ next unless $self->get_files('', $media->{src}{$m}, $source_pattern);
+ } else {
+ next unless $self->get_files('', $media->{$arch}{$m}, $binary_pattern);
+ }
+ $section = $m;
+ last;
+ }
+ }
+
+ # FIXME: doing this here is wrong; this way the caller can never know if
+ # a section was actually found or not; should return undef and let the
+ # caller set a default (Note: IIRC PLF|Zarb has this right, see there) -spuk
+ print STDERR "Warning: Can't guess destination: section missing, defaulting to contrib/release\n" unless $section;
+ $section ||= 'contrib/release';
+
+ # next time we don't need to search everything again
+ $self->{packages}{$file}{section} = $section;
+
+ print "Section is '$section'.\n";
+
+ return $section;
+}
+
+sub get_upload_newer_revisions {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ my $name = $package->get_full_name;
+ $name =~ s/^\@\d+://;
+ my $pattern = $self->get_package_class()->get_pattern($package->get_name(), undef, undef, $arch);
+ my $media = $self->_get_media_config($target);
+ my @packages;
+ foreach my $state (@{$self->{_upload_state}}) {
+ foreach my $m (keys %{$media->{$arch}}) {
+ my $path = "$self->{_upload_root}/$state/$target/$m";
+ print "Looking for package $package revisions for $target in $path (pattern $pattern)\n" if $self->{_verbose};
+ find(
+ sub {
+ s/\d{14}\.[^.]*\.[^.]*\.\d+_//;
+ s/^\@\d+://;
+ return if ! /^$pattern/;
+ return if /\.info$/;
+ print "Find $_\n";
+ push @packages, $File::Find::name if $package->check_ranges_compatibility("== $name", "< $_")
+ }, $path);
+ }
+ }
+ return
+ @packages;
+}
+
+sub package_in_svn {
+ my ($self, $srpm_name) = @_;
+ my $ctx = new SVN::Client(
+ auth => [SVN::Client::get_simple_provider(),
+ SVN::Client::get_simple_prompt_provider(\&simple_prompt,2),
+ SVN::Client::get_username_provider()]
+ );
+
+ my $svn_entry = $ctx->ls("$self->{_svn}/$srpm_name", 'HEAD', 0);
+ if ($svn_entry) {
+ print "Package $srpm_name is in the SVN\n";
+ return 1
+ }
+}
+
+sub get_svn_url {
+ my ($self) = @_;
+ $self->{_svn}
+}
+
+sub get_revisions {
+ my ($self, $package, $target, $user_context, $app_context, $filter) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for package $package revisions for $target\n" if $self->{_verbose} > 0;
+
+ my $arch = $app_context->{arch} || $user_context->{arch} || $package->get_arch();
+ my $media_arch = $arch eq 'noarch' ? $self->{_noarch} : $arch;
+ my $path = $arch eq 'src' ? "$target/SRPMS/" : "$target/$media_arch/media";
+ my $media = $self->_get_section($package, $target, $user_context, $app_context);
+ my $name = $package->get_name();
+ my @packages = map { $self->get_package_class()->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ "$path/$media",
+ $self->get_package_class()->get_pattern(
+ $name,
+ undef,
+ undef,
+ $package->get_arch(),
+ )
+ );
+
+ @packages = grep { $filter->($_) } @packages if $filter;
+
+ return
+ sort { $b->compare($a) } # sort by revision order
+ @packages;
+}
+
+sub reject {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+
+}
+
+sub get_archive_dir {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->{_archive_root}
+}
+
+
+# 20060801 warly
+#
+# Upload steps
+# SRPMS are uploaded in /home/mandrake/uploads/todo/$target/$media/group_id
+#
+#
+#
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload_pre.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload_pre.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Repository/Mandriva_upload_pre.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,274 @@
+# $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 = $define->{arch} || $package->get_arch;
+ if ($arch eq 'src') {
+ $arch = 'SRPMS'
+ } else {
+ $arch .= '/media'
+ }
+ my @packages;
+ foreach my $dir ('main', 'contrib') {
+ print "Looking into $self->{_install_root}/$target/$arch/$dir/release\n";
+ push @packages,
+ map { $self->get_package_class()->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ "$target/$arch/$dir/release" ,
+ $self->get_package_class()->get_pattern($package->get_name(),undef, undef, $arch)
+ );
+ }
+
+ @packages = grep { $filter->($_) } @packages if $filter;
+
+ return
+ sort { $b->compare($a) } # sort by revision order
+ @packages;
+}
+
+sub get_package_charset {
+ return PACKAGE_CHARSET;
+}
+
+sub get_upload_dir {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ my $section = $self->_get_section($package, $target, $define);
+ my $media_path = $section eq 'main' ? $target : $target =~ /^cooker/ ? "contrib" : "$target/contrib";
+ my $arch_path = $arch eq 'src' ? 'SRPMS' : 'RPMS';
+ my $force = $target =~ /_force/ ? 'force' : '';
+ $self->{_upload_root} . "/$media_path/$force/$arch_path/"
+}
+
+sub get_arch {
+ my ($self, $package, $target, $define) = @_;
+ my $arch = $package->get_arch();
+ if ($arch eq 'noarch') {
+ $arch = $self->{_noarch}
+ }
+ $arch
+}
+
+sub get_install_path {
+ my ($self, $package, $target, $define) = @_;
+
+ return $self->_get_path($package, $target, $define);
+}
+
+sub get_archive_path {
+ my ($self, $package, $target, $define) = @_;
+
+ return $self->_get_path($package, $target, $define);
+}
+
+sub _get_path {
+ my ($self, $package, $target, $define) = @_;
+
+ my $arch = $package->get_arch;
+ if ($arch eq 'src') {
+ $arch = 'SRPMS'
+ } else {
+ $arch .= '/media'
+ }
+ my $section = $self->_get_section($package, $target, $define);
+
+ return "$target/$arch/$section/release/";
+}
+
+
+sub get_version_path {
+ my ($self, $package, $target, $define) = @_;
+
+ my $section = $self->_get_section($package, $target, $define);
+
+ return "$self->{_module}/$section/release/";
+}
+
+=head2 get_replaced_packages($package, $target, $define)
+
+Overrides parent method to add libified packages.
+
+=cut
+
+sub get_replaced_packages {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my @replaced_packages =
+ $self->SUPER::get_replaced_packages($package, $target, $define);
+
+ # mandriva lib policy:
+ # library package names change with revision, making mandatory to
+ # duplicate older revisions search with a custom pattern
+ my $name = $package->get_name();
+ if ($name =~ /^(lib\w+[a-zA-Z_])[\d_\.]+([-\w]*)$/) {
+ push(@replaced_packages,
+ grep { $package->compare($_) > 0 }
+ map { PACKAGE_CLASS->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ $self->get_install_path($package, $target, $define),
+ PACKAGE_CLASS->get_pattern(
+ $1 . '[\d_\.]+' . $2, # custom name pattern
+ undef,
+ undef,
+ $package->get_arch()
+ ),
+ )
+ );
+ }
+
+ return @replaced_packages;
+
+}
+
+sub _get_section {
+ my ($self, $package, $target, $define) = @_;
+
+ my $section;
+
+ # try to find section automatically
+ my $arch = $package->get_arch();
+ $arch = $self->{_noarch} if $arch eq 'noarch';
+
+ my $source_pattern = PACKAGE_CLASS->get_pattern(
+ $package->get_canonical_name(),
+ undef,
+ undef,
+ 'src'
+ );
+
+ my $binary_pattern = PACKAGE_CLASS->get_pattern(
+ $package->get_name(),
+ undef,
+ undef,
+ $arch
+ );
+
+ # for each potential section, try to match
+ # a suitable source patten in source directory
+ # a suitable binary patten in binary directory
+ foreach my $dir (qw/main contrib/) {
+ next unless
+ $self->get_files(
+ $self->{_install_root},
+ "$target/SRPMS/$dir/release",
+ $source_pattern
+ ) || $self->get_files(
+ $self->{_install_root},
+ "$target/$arch/media/$dir/release",
+ $binary_pattern
+ );
+ print "Section is $dir\n";
+ $section = $dir;
+ last;
+ }
+
+ # use defined section if not found
+ $section = $define->{section} unless $section;
+
+ $section || 'contrib'
+}
+
+sub get_upload_newer_revisions {
+ my ($self, $package, $target, $define) = @_;
+ croak "Not a class method" unless ref $self;
+ my $arch = $package->get_arch();
+ my $pattern = $self->get_package_class()->get_pattern($package->get_name(), undef, undef, $arch);
+ print "Looking for package $package revisions for $target in $self->{_upload_root} (pattern $pattern)\n";
+ my @packages;
+ foreach my $dir ('cooker', 'contrib') {
+ find(sub { return if ! /^$pattern/; print "Find $_\n"; push @packages, $File::Find::name if $package->compare($self->get_package_class()->new(file => $File::Find::name)) <= 0 }, "$self->{_upload_root}/$dir");
+ }
+ return
+ @packages;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Repository/PLF.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Repository/PLF.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Repository/PLF.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -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;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Repository.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Repository.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Repository.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,492 @@
+# $Id: Base.pm 631 2006-01-26 22:22:23Z guillomovitch $
+package Youri::Repository;
+
+=head1 NAME
+
+Youri::Repository - Abstract repository
+
+=head1 DESCRIPTION
+
+This abstract class defines Youri::Repository interface.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use File::Basename;
+use Youri::Package;
+
+=head1 CLASS METHODS
+
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Repository object.
+
+No generic parameters (subclasses may define additional ones).
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ install_root => '', # path to top-level directory
+ archive_root => '', # path to top-level directory
+ version_root => '', # path to top-level directory
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ @_
+ );
+
+
+ croak "no install root" unless $options{install_root};
+ croak "invalid install root" unless -d $options{install_root};
+
+ my $self = bless {
+ _install_root => $options{install_root},
+ _archive_root => $options{archive_root},
+ _version_root => $options{version_root},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+=head2 get_package_class()
+
+Return package class for this repository.
+
+=cut
+
+sub get_package_class {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+ return $self->{_package_class};
+}
+
+=head2 get_package_charset()
+
+Return package charset for this repository.
+
+=cut
+
+sub get_package_charset {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+ return $self->{_package_charset};
+}
+
+=head2 get_extra_arches()
+
+Return the list of additional archictectures to handle when dealing with noarch
+packages.
+
+=cut
+
+sub get_extra_arches {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+ return @{$self->{_extra_arches}};
+}
+
+
+=head2 get_older_revisions($package, $target, $user_context, $app_context)
+
+Get all older revisions from a package found in its installation directory, as a
+list of L<Youri::Package> objects.
+
+=cut
+
+sub get_older_revisions {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for package $package older revisions for $target\n"
+ if $self->{_verbose} > 0;
+
+ return $self->get_revisions(
+ $package,
+ $target,
+ $user_context,
+ $app_context,
+ sub { return $package->compare($_[0]) > 0 }
+ );
+}
+
+=head2 get_last_older_revision($package, $target, $user_context, $app_context)
+
+Get last older revision from a package found in its installation directory, as a
+single L<Youri::Package> object.
+
+=cut
+
+sub get_last_older_revision {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for package $package last older revision for $target\n"
+ if $self->{_verbose} > 0;
+
+ return (
+ $self->get_older_revisions(
+ $package,
+ $target,
+ $user_context,
+ $app_context
+ )
+ )[0];
+}
+
+=head2 get_newer_revisions($package, $target, $user_context, $app_context)
+
+Get all newer revisions from a package found in its installation directory, as
+a list of L<Youri::Package> objects.
+
+=cut
+
+sub get_newer_revisions {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for package $package newer revisions for $target\n"
+ if $self->{_verbose} > 0;
+
+ return $self->get_revisions(
+ $package,
+ $target,
+ $user_context,
+ $app_context,
+ sub { return $_[0]->compare($package) > 0 }
+ );
+}
+
+
+=head2 get_revisions($package, $target, $user_context, $app_context, $filter)
+
+Get all revisions from a package found in its installation directory, using an
+optional filter, as a list of L<Youri::Package> objects.
+
+=cut
+
+sub get_revisions {
+ my ($self, $package, $target, $user_context, $app_context, $filter) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for package $package revisions for $target\n"
+ if $self->{_verbose} > 0;
+
+ my @packages =
+ map { $self->get_package_class()->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ $self->get_install_path(
+ $package,
+ $target,
+ $user_context,
+ $app_context
+ ),
+ $self->get_package_class()->get_pattern(
+ $package->get_name(),
+ undef,
+ undef,
+ $package->get_arch(),
+ )
+ );
+ @packages = grep { $filter->($_) } @packages if $filter;
+
+ return
+ sort { $b->compare($a) } # sort by revision order
+ @packages;
+}
+
+=head2 get_obsoleted_packages($package, $target, $user_context, $app_context)
+
+Get all packages obsoleted by given one, as a list of L<Youri::Package>
+objects.
+
+=cut
+
+sub get_obsoleted_packages {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for packages obsoleted by $package for $target\n"
+ if $self->{_verbose} > 0;
+
+ my @packages;
+ foreach my $obsolete ($package->get_obsoletes()) {
+ my $pattern = $self->get_package_class()->get_pattern($obsolete->[Youri::Package::DEPENDENCY_NAME]);
+ my $range = $obsolete->[Youri::Package::DEPENDENCY_RANGE];
+ push(@packages,
+ grep { $range ? $_->satisfy_range($range) : 1 }
+ map { $self->get_package_class()->new(file => $_) }
+ $self->get_files(
+ $self->{_install_root},
+ $self->get_install_path(
+ $package, $target,
+ $user_context,
+ $app_context
+ ),
+ $pattern
+ )
+ );
+ }
+
+ return @packages;
+}
+
+=head2 get_replaced_packages($package, $target, $user_context, $app_context)
+
+Get all packages replaced by given one, as a list of L<Youri::Package>
+objects.
+
+=cut
+
+sub get_replaced_packages {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+ print "Looking for packages replaced by $package for $target\n"
+ if $self->{_verbose} > 0;
+
+ my @list;
+
+ # collect all older revisions
+ push(@list, $self->get_older_revisions(
+ $package,
+ $target,
+ $user_context,
+ $app_context
+ ));
+
+ # noarch packages are potentially linked from other directories
+ if ($package->get_arch() eq 'noarch') {
+ foreach my $arch ($self->get_extra_arches()) {
+ push(@list, $self->get_older_revisions(
+ $package,
+ $target,
+ $user_context,
+ { arch => $arch }
+ ));
+ }
+ }
+
+ # collect all obsoleted packages
+ push(@list, $self->get_obsoleted_packages(
+ $package,
+ $target,
+ $user_context,
+ $app_context
+ ));
+
+ return @list;
+}
+
+=head2 get_files($path, $pattern)
+
+Get all files found in a directory, using an optional filtering pattern
+(applied to the whole file name), as a list of files.
+
+=cut
+
+sub get_files {
+ my ($self, $root, $path, $pattern) = @_;
+ croak "Not a class method" unless ref $self;
+ # debugging for bug 34999
+ print "Looking for files matching $pattern in $root/$path\n";
+# if $self->{_verbose} > 1;
+
+ my $grep = "";
+ $grep = "-regextype posix-egrep -regex '.*\/$pattern'" if ($pattern);
+ # XXX: run find in a directory the user is guaranteed to have read
+ # permissions! find simply exits with error if the user doesn't have
+ # read permission on the *current* dir; as this code is run thru many
+ # sudo invocations, sometimes the user calling it has $HOME chmoded to
+ # 0700, making find fail when run as mandrake
+ # debugging for bug 34999
+ print ".. running command: find -L $root/$path $grep -type f\n";
+ my @files = map { chop; $_; } `cd && find -L $root/$path $grep -type f`;
+ die "FATAL: get_files(): find failed!" if ($?);
+
+ return @files;
+}
+
+=head2 get_install_root()
+
+Returns installation root
+
+=cut
+
+sub get_install_root {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_install_root};
+}
+
+
+=head2 get_distribution_roots()
+
+Returns distribution roots (ie install_root + target + arch)
+(it returns a list in case of noarch)
+
+=cut
+
+sub get_distribution_roots {
+ my ($self, $package, $target) = @_;
+ croak "Not a class method" unless ref $self;
+
+ map {
+ $self->_get_dir($self->{_install_root}, $_);
+ } $self->get_distribution_paths($package, $target);
+}
+
+=head2 get_install_dir($package, $target, $user_context, $app_context)
+
+Returns install destination directory for given L<Youri::Package> object
+and given target.
+
+=cut
+
+sub get_install_dir {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->_get_dir(
+ $self->{_install_root},
+ $self->get_install_path($package, $target, $user_context, $app_context)
+ );
+}
+
+=head2 get_archive_root()
+
+Returns archiving root
+
+=cut
+
+sub get_archive_root {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_archive_root};
+}
+
+=head2 get_archive_dir($package, $target, $user_context, $app_context)
+
+Returns archiving destination directory for given L<Youri::Package> object
+and given target.
+
+=cut
+
+sub get_archive_dir {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->_get_dir(
+ $self->{_archive_root},
+ $self->get_archive_path($package, $target, $user_context, $app_context)
+ );
+}
+
+
+=head2 get_version_root()
+
+Returns versionning root
+
+=cut
+
+sub get_version_root {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_version_root};
+}
+
+=head2 get_version_dir($package, $target, $user_context, $app_context)
+
+Returns versioning destination directory for given L<Youri::Package>
+object and given target.
+
+=cut
+
+sub get_version_dir {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->_get_dir(
+ $self->{_version_root},
+ $self->get_version_path($package, $target, $user_context, $app_context)
+ );
+}
+
+sub _get_dir {
+ my ($self, $root, $path) = @_;
+
+ return substr($path, 0, 1) eq '/' ?
+ $path :
+ $root . '/' . $path;
+}
+
+=head2 get_install_file($package, $target, $user_context, $app_context)
+
+Returns install destination file for given L<Youri::Package> object and
+given target.
+
+=cut
+
+sub get_install_file {
+ my ($self, $package, $target, $user_context, $app_context) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return
+ $self->get_install_dir($package, $target, $user_context, $app_context) .
+ '/' .
+ $package->get_file_name();
+}
+
+=head2 get_install_path($package, $target, $user_context, $app_context)
+
+Returns installation destination path (relative to repository root) for given
+L<Youri::Package> object and given target.
+
+=head2 get_archive_path($package, $target, $user_context, $app_context)
+
+Returns archiving destination path (relative to repository root) for given
+L<Youri::Package> object and given target.
+
+=head2 get_version_path($package, $target, $user_context, $app_context)
+
+Returns versioning destination path (relative to repository root) for given
+L<Youri::Package> object and given target.
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item get_install_path
+
+=item get_archive_path
+
+=item get_version_path
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/lib/Youri/Utils.pm
===================================================================
--- build_system/mdv-youri-core/trunk/lib/Youri/Utils.pm (rev 0)
+++ build_system/mdv-youri-core/trunk/lib/Youri/Utils.pm 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,98 @@
+# $Id: Utils.pm 1713 2006-10-16 16:39:53Z warly $
+package Youri::Utils;
+
+=head1 NAME
+
+Youri::Utils - Youri shared functions
+
+=head1 DESCRIPTION
+
+This module implement some helper functions for all youri applications.
+
+=cut
+
+use base qw(Exporter);
+use Carp;
+use strict;
+use warnings;
+
+our @EXPORT = qw(
+ create_instance
+ load_class
+ add2hash
+ add2hash_
+);
+
+=head2 create_instance($class, $config, $options)
+
+Create an instance from a plugin implementing given interface, using given
+configuration and local options.
+Returns a plugin instance, or undef if something went wrong.
+
+=cut
+
+sub create_instance {
+ my ($interface, $config, $options) = @_;
+
+ croak 'No interface given' unless $interface;
+ croak 'No config given' unless $config;
+
+ my $class = $config->{class};
+ if (!$class) {
+ carp "No class given, can't load plugin";
+ return;
+ }
+
+ # ensure loaded
+ load_class($class);
+
+ # check interface
+ if (!$class->isa($interface)) {
+ carp "$class is not a $interface";
+ return;
+ }
+
+ # instantiate
+ no strict 'refs';
+
+ return $class->new(
+ $config->{options} ? %{$config->{options}} : (),
+ $options ? %{$options} : (),
+ );
+}
+
+sub load_class {
+ my ($class) = @_;
+
+ $class .= '.pm';
+ $class =~ s/::/\//g;
+ require $class;
+}
+
+# structure helpers
+
+sub add2hash {
+ my ($a, $b) = @_;
+ while (my ($k, $v) = each %{$b || {}}) {
+ $a->{$k} ||= $v;
+ }
+ return $a;
+}
+
+sub add2hash_ {
+ my ($a, $b) = @_;
+ while (my ($k, $v) = each %{$b || {}}) {
+ exists $a->{$k} or $a->{$k} = $v;
+ }
+ return $a;
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;
Added: build_system/mdv-youri-core/trunk/t/00distribution.t
===================================================================
--- build_system/mdv-youri-core/trunk/t/00distribution.t (rev 0)
+++ build_system/mdv-youri-core/trunk/t/00distribution.t 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+# $Id: 00distribution.t 1179 2006-08-05 08:30:57Z warly $
+
+use Test::More;
+
+BEGIN {
+ eval {
+ require Test::Distribution;
+ };
+ if($@) {
+ plan skip_all => 'Test::Distribution not installed';
+ } else {
+ import Test::Distribution only => [ qw/use pod description/ ];
+ }
+}
Property changes on: build_system/mdv-youri-core/trunk/t/00distribution.t
___________________________________________________________________
Added: svn:executable
+ *
Added: build_system/mdv-youri-core/trunk/t/cowsay-3.03-11mdv2007.0.noarch.rpm
===================================================================
(Binary files differ)
Property changes on: build_system/mdv-youri-core/trunk/t/cowsay-3.03-11mdv2007.0.noarch.rpm
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: build_system/mdv-youri-core/trunk/t/gpghome/pubring.gpg
===================================================================
(Binary files differ)
Property changes on: build_system/mdv-youri-core/trunk/t/gpghome/pubring.gpg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: build_system/mdv-youri-core/trunk/t/gpghome/secring.gpg
===================================================================
(Binary files differ)
Property changes on: build_system/mdv-youri-core/trunk/t/gpghome/secring.gpg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: build_system/mdv-youri-core/trunk/t/gpghome/trustdb.gpg
===================================================================
(Binary files differ)
Property changes on: build_system/mdv-youri-core/trunk/t/gpghome/trustdb.gpg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: build_system/mdv-youri-core/trunk/t/package.t
===================================================================
--- build_system/mdv-youri-core/trunk/t/package.t (rev 0)
+++ build_system/mdv-youri-core/trunk/t/package.t 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,482 @@
+#!/usr/bin/perl
+# $Id: /local/youri/soft/trunk/t/version.t 2257 2006-07-05T09:22:47.088572Z guillaume $
+
+use Test::More;
+use Test::Exception;
+use Youri::Utils;
+use File::Temp qw/tempdir/;
+use File::Basename;
+use strict;
+
+my @classes = qw/
+ Youri::Package::URPM
+ Youri::Package::RPM4
+/;
+my $dir = dirname($0);
+my $rpm = 'cowsay-3.03-11mdv2007.0.noarch.rpm';
+my $fake_rpm = 'foobar.rpm';
+plan(tests => 37 * scalar @classes);
+
+foreach my $class (@classes) {
+ load_class($class);
+
+ my $temp_dir = tempdir(CLEANUP => 1);
+ my $file = "$dir/$rpm";
+ my $fake_file = "$temp_dir/$fake_rpm";
+
+ # instanciation errors
+ dies_ok { $class->new(file => undef) } 'undefined file';
+ dies_ok { $class->new(file => $fake_file) } 'non-existant file';
+ system('touch', $fake_file);
+ chmod 0000, $fake_file;
+ dies_ok { $class->new(file => $fake_file) } 'non-readable file';
+ chmod 0644, $fake_file;
+ dies_ok { $class->new(file => $fake_file) } 'non-rpm file';
+
+ my $package = $class->new(file => $file);
+ isa_ok($package, $class);
+
+ # tag value access
+ is($package->get_name(), 'cowsay', 'get name directly');
+ is($package->get_tag('name'), 'cowsay', 'get name indirectly');
+ is($package->get_version(), '3.03', 'get version directly');
+ is($package->get_tag('version'), '3.03', 'get version indirectly');
+ is($package->get_release(), '11mdv2007.0', 'get release directly');
+ is($package->get_tag('release'), '11mdv2007.0', 'get release indirectly');
+ is($package->get_arch(), 'noarch', 'get arch directly');
+ is($package->get_tag('arch'), 'noarch', 'get arch indirectly');
+ is($package->get_summary(), 'Configurable talking cow', 'get summary directly');
+ is($package->get_tag('summary'), 'Configurable talking cow', 'get summary indirectly');
+ is($package->get_url(), 'http://www.nog.net/~tony/warez/cowsay.shtml', 'get url directly');
+ is($package->get_tag('url'), 'http://www.nog.net/~tony/warez/cowsay.shtml', 'get url indirectly');
+ is($package->get_packager(), 'Guillaume Rousse <guillomovitch at mandriva.org>', 'get packager directly');
+ is($package->get_tag('packager'), 'Guillaume Rousse <guillomovitch at mandriva.org>', 'get packager indirectly');
+ is($package->get_file_name(), 'cowsay-3.03-11mdv2007.0.noarch.rpm', 'file name');
+ is($package->get_revision(), '3.03-11mdv2007.0', 'revision');
+
+ # name formating
+ is($package->as_formated_string('%{name}-%{version}-%{release}'), 'cowsay-3.03-11mdv2007.0', 'formated string name');
+ is($package->as_string(), 'cowsay-3.03-11mdv2007.0.noarch', 'default string');
+ is($package, 'cowsay-3.03-11mdv2007.0.noarch', 'stringification');
+
+ # type
+ ok(!$package->is_source(), 'not a source package');
+ ok($package->is_binary(), 'a binary package');
+ is($package->get_type(), 'binary', 'a binary package');
+
+ # gpg key
+ is($package->get_gpg_key(), '26752624', 'get gpg key');
+
+ # dependencies
+ is_deeply(
+ [ $package->get_requires() ],
+ [
+ [ 'perl-base', undef ],
+ [ 'perl(Cwd)', undef ],
+ [ 'perl(File::Basename)', undef ],
+ [ 'perl(Getopt::Std)', undef ],
+ [ 'perl(Text::Tabs)', undef ],
+ [ 'perl(Text::Wrap)', undef ]
+ ],
+ 'requires'
+ );
+ is_deeply(
+ [ $package->get_provides() ],
+ [
+ [ 'cowsay', '== 3.03-11mdv2007.0']
+ ],
+ 'provides'
+ );
+ is_deeply(
+ [ $package->get_obsoletes() ],
+ [ ],
+ 'obsoletes'
+ );
+ is_deeply(
+ [ $package->get_conflicts() ],
+ [ ],
+ 'conflicts'
+ );
+
+ # files
+ is_deeply(
+ [ $package->get_files() ],
+ [
+ [
+ '/etc/bash_completion.d/cowsay',
+ 33188,
+ '6048be1dd827011c15cab0c3db1f438d'
+ ],
+ [
+ '/usr/bin/cowsay',
+ 33261,
+ 'b405026c6040eeb4781ca5c523129fe4'
+ ],
+ [
+ '/usr/bin/cowthink',
+ 41471,
+ ''
+ ],
+ [
+ '/usr/share/cows',
+ 16877,
+ ''
+ ],
+ [
+ '/usr/share/cows/beavis.zen.cow',
+ 33188,
+ '582b2ddb72122d3aa078730abd0456b3'
+ ],
+ [
+ '/usr/share/cows/bong.cow',
+ 33188,
+ '045f9bf39c027dded9a7145f619bac02'
+ ],
+ [
+ '/usr/share/cows/bud-frogs.cow',
+ 33188,
+ '5c61632eb06305d613061882e1955cd2'
+ ],
+ [
+ '/usr/share/cows/bunny.cow',
+ 33188,
+ '05eb914d3b96aea903542cb29f5c42c7'
+ ],
+ [
+ '/usr/share/cows/cheese.cow',
+ 33188,
+ 'f3618110a22d8e9ecde888c1f5e38b61'
+ ],
+ [
+ '/usr/share/cows/cower.cow',
+ 33188,
+ 'd73ea60eec692555a34a9f3eec981578'
+ ],
+ [
+ '/usr/share/cows/daemon.cow',
+ 33188,
+ 'a7dd7588ee0386a0f29e88e4881885ee'
+ ],
+ [
+ '/usr/share/cows/default.cow',
+ 33188,
+ 'f1206515a0f27e9d5cf09c188e46bc82'
+ ],
+ [
+ '/usr/share/cows/dragon-and-cow.cow',
+ 33188,
+ '0ca99b8edd1a9d14fd231a88d9746b39'
+ ],
+ [
+ '/usr/share/cows/dragon.cow',
+ 33188,
+ '448f736bf56dccafa2635e71e7485345'
+ ],
+ [
+ '/usr/share/cows/duck.cow',
+ 33188,
+ 'd8ffcd64667d2e3697a3e8b65e8bea9d'
+ ],
+ [
+ '/usr/share/cows/elephant-in-snake.cow',
+ 33188,
+ 'c5a9f406277e0e8a674bd3ffb503738f'
+ ],
+ [
+ '/usr/share/cows/elephant.cow',
+ 33188,
+ 'e355c72e893787376c047805d4a1fe9d'
+ ],
+ [
+ '/usr/share/cows/eyes.cow',
+ 33188,
+ 'b2eb5b612fae17877895aa6edafa0a5f'
+ ],
+ [
+ '/usr/share/cows/flaming-sheep.cow',
+ 33188,
+ '3213cfa04a069f42d71115ca623a2f95'
+ ],
+ [
+ '/usr/share/cows/ghostbusters.cow',
+ 33188,
+ 'df294e6278bcb275aecb0fbd6b2546ba'
+ ],
+ [
+ '/usr/share/cows/girafe.cow',
+ 33188,
+ '6d2e142313109b6a5a0a45dba0f11351'
+ ],
+ [
+ '/usr/share/cows/head-in.cow',
+ 33188,
+ '365287a5d1f34a53f8716285e79c28df'
+ ],
+ [
+ '/usr/share/cows/hellokitty.cow',
+ 33188,
+ 'e0bbea69c4cbcfb3d799740ccc8a0b0e'
+ ],
+ [
+ '/usr/share/cows/kenny.cow',
+ 33188,
+ '16ce8c334a7547197ac4c9e8a1d6ae90'
+ ],
+ [
+ '/usr/share/cows/kiss.cow',
+ 33188,
+ '2a7bdd4a20741b7769af463bf09e64e8'
+ ],
+ [
+ '/usr/share/cows/kitty.cow',
+ 33188,
+ '76d65a3ebfbacb16a654c1aa1af6ed27'
+ ],
+ [
+ '/usr/share/cows/koala.cow',
+ 33188,
+ 'cc524706707f32253dd06fc548334f11'
+ ],
+ [
+ '/usr/share/cows/kosh.cow',
+ 33188,
+ 'e4e28e0f472bd524fd1b44c67ae357c2'
+ ],
+ [
+ '/usr/share/cows/luke-koala.cow',
+ 33188,
+ '63bbc35da73cd22b8cf25f86dcf9f870'
+ ],
+ [
+ '/usr/share/cows/mech-and-cow',
+ 33188,
+ '12c0320b33704d8564dd97278d056204'
+ ],
+ [
+ '/usr/share/cows/meow.cow',
+ 33188,
+ 'a6092008647ed37cfe1663d10e388cbb'
+ ],
+ [
+ '/usr/share/cows/milk.cow',
+ 33188,
+ 'd26ac36e13e77dabb408e104fc8e0167'
+ ],
+ [
+ '/usr/share/cows/moofasa.cow',
+ 33188,
+ '5fcdd4a9f3bf521c337af0a066b14512'
+ ],
+ [
+ '/usr/share/cows/moose.cow',
+ 33188,
+ 'dcfa09df7d2b9afa112dab374bf06e99'
+ ],
+ [
+ '/usr/share/cows/mutilated.cow',
+ 33188,
+ '24cdaef0a29fb44dc673abf19a8ba631'
+ ],
+ [
+ '/usr/share/cows/phaco.cow',
+ 33188,
+ 'f277c1bf92ce2a3f6058955ba93758aa'
+ ],
+ [
+ '/usr/share/cows/pumpkin.cow',
+ 33188,
+ 'c661ea78714c1ce31559f77d73694473'
+ ],
+ [
+ '/usr/share/cows/ren.cow',
+ 33188,
+ '3d7941d454779e000adc1c91e5f0b20b'
+ ],
+ [
+ '/usr/share/cows/satanic.cow',
+ 33188,
+ 'a69ca42a31486757ddcb322a1e68f886'
+ ],
+ [
+ '/usr/share/cows/shark.cow',
+ 33188,
+ 'd8950ec63abb00bbd9d96ec63637c1ac'
+ ],
+ [
+ '/usr/share/cows/sheep.cow',
+ 33188,
+ '543b75f295cbd51326f5a40f111469f1'
+ ],
+ [
+ '/usr/share/cows/skeleton.cow',
+ 33188,
+ '64f6ec1a0c170508e72269d533492e57'
+ ],
+ [
+ '/usr/share/cows/small.cow',
+ 33188,
+ '50cb1c55628c439fc81f96db9d855252'
+ ],
+ [
+ '/usr/share/cows/sodomized.cow',
+ 33188,
+ 'b4888afcca51629cc3138b283608b837'
+ ],
+ [
+ '/usr/share/cows/stegosaurus.cow',
+ 33188,
+ 'fb0e45d101a3ecba9cf6e112facbbc7e'
+ ],
+ [
+ '/usr/share/cows/stimpy.cow',
+ 33188,
+ '9b4ec6e0750ba0eeaaa432d8d3413559'
+ ],
+ [
+ '/usr/share/cows/supermilker.cow',
+ 33188,
+ '316573fb585e4a6b375373c85be025b1'
+ ],
+ [
+ '/usr/share/cows/surgery.cow',
+ 33188,
+ '7f25005083c1fde19d4e548c005ef000'
+ ],
+ [
+ '/usr/share/cows/telebears.cow',
+ 33188,
+ '15f00abb070d9018ce6ef3441e936ef4'
+ ],
+ [
+ '/usr/share/cows/three-eyes.cow',
+ 33188,
+ 'c85faef9496f4a5b111bd92bfd7e7528'
+ ],
+ [
+ '/usr/share/cows/turkey.cow',
+ 33188,
+ '484b5bc69c09d420d7fd5586d8570f04'
+ ],
+ [
+ '/usr/share/cows/turtle.cow',
+ 33188,
+ '87eed5a00e88860b78dbec04efcdede3'
+ ],
+ [
+ '/usr/share/cows/tux.cow',
+ 33188,
+ 'dc1db4eac66c99179ef6adb15dd75bda'
+ ],
+ [
+ '/usr/share/cows/udder.cow',
+ 33188,
+ 'd97f78887c3b218a54876edc51f2963b'
+ ],
+ [
+ '/usr/share/cows/vader-koala.cow',
+ 33188,
+ '7b5dd51278f0fa217a70a9b499f97a07'
+ ],
+ [
+ '/usr/share/cows/vader.cow',
+ 33188,
+ '97b4ef9fc4c26082f253e9f0f35c4590'
+ ],
+ [
+ '/usr/share/cows/www.cow',
+ 33188,
+ 'ef4c0bc8330f329666e1705f97f283cc'
+ ],
+ [
+ '/usr/share/doc/cowsay-3.03',
+ 16877,
+ ''
+ ],
+ [
+ '/usr/share/doc/cowsay-3.03/INSTALL',
+ 33188,
+ '3333fd2865107626d5dffc0dbfb7e244'
+ ],
+ [
+ '/usr/share/doc/cowsay-3.03/LICENSE',
+ 33188,
+ 'f879dda90a5a9928253a63ecd76406e6'
+ ],
+ [
+ '/usr/share/doc/cowsay-3.03/README',
+ 33188,
+ 'a5c1c61e4920c278a735cdaaca62453e'
+ ],
+ [
+ '/usr/share/man/man1/cowsay.1.bz2',
+ 33188,
+ '01fdd49d0b477f20099aae384fe8c1b2'
+ ],
+ [
+ '/usr/share/man/man1/cowthink.1.bz2',
+ 41471,
+ ''
+ ]
+ ],
+ 'files'
+ );
+
+ # changelog
+ is_deeply(
+ [ $package->get_changes() ],
+ [
+ [
+ 'Guillaume Rousse <guillomovitch at mandriva.org> 3.03-11mdv2007.0',
+ 1149847200,
+ '- %mkrel' . "\n" .
+ '- rpmbuildupdate aware',
+ ],
+ [
+ 'Guillaume Rousse <guillomovitch at mandriva.org> 3.03-10mdk ',
+ 1117879200,
+ '- fix man page (fix #16291)',
+ ],
+ [
+ 'Guillaume Rousse <guillomovitch at mandrake.org> 3.03-9mdk ',
+ 1090058400,
+ '- hurry businesman compliant (aka two new wonderful cows)',
+ ],
+ [
+ 'Guillaume Rousse <guillomovitch at mandrake.org> 3.03-8mdk ',
+ 1089540000,
+ '- apologies to the girafes (with one only f)',
+ ],
+ [
+ 'Guillaume Rousse <guillomovitch at mandrake.org> 3.03-7mdk ',
+ 1086429600,
+ '- #mandrakefr compliant (aka four new additional cows)',
+ ],
+ [
+ 'Guillaume Rousse <guillomovitch at linux-mandrake.com> 3.03-6mdk',
+ 1061460000,
+ '- save.the.world patch',
+ ]
+ ],
+ 'changelog'
+ );
+ is_deeply(
+ $package->get_last_change(),
+ [
+ 'Guillaume Rousse <guillomovitch at mandriva.org> 3.03-11mdv2007.0',
+ 1149847200,
+ '- %mkrel' . "\n" .
+ '- rpmbuildupdate aware',
+ ],
+ 'last change'
+ );
+ is($package->compare($package), 0, 'compare');
+
+ # signature test
+ system('cp', $file, $temp_dir);
+ $package = $class->new(file => "$temp_dir/$rpm");
+
+ $package->sign('Youri', 't/gpghome', 'Youri rulez');
+
+ $package = $class->new(file => "$temp_dir/$rpm");
+ is($package->get_gpg_key(), '2333e817', 'get gpg key');
+}
Property changes on: build_system/mdv-youri-core/trunk/t/package.t
___________________________________________________________________
Added: svn:executable
+ *
Added: build_system/mdv-youri-core/trunk/t/version.t
===================================================================
--- build_system/mdv-youri-core/trunk/t/version.t (rev 0)
+++ build_system/mdv-youri-core/trunk/t/version.t 2011-01-05 13:23:45 UTC (rev 210)
@@ -0,0 +1,71 @@
+#!/usr/bin/perl
+# $Id: version.t 1179 2006-08-05 08:30:57Z warly $
+
+use Test::More;
+use Youri::Check::Input::Updates;
+use strict;
+
+my @differents = (
+ [ '3.0.0', '1.0.0' ],
+ [ '3.0.0', '1.99.9' ],
+ [ '3.0.1', '3.0' ],
+ [ '3.0pl1', '3.0' ],
+ [ '3.0', '3.0beta1' ],
+ [ '3.0', '3.0beta' ],
+ [ '3.0', '3.0alpha1' ],
+ [ '3.0', '3.0alpha' ],
+ [ '3.0', '3.0pre1' ],
+ [ '3.0', '3.0pre' ],
+ [ '3.0pre', '3.0beta' ],
+ [ '3.0beta', '3.0alpha' ],
+ [ '1.0.0-p1', '1.0.0RC1' ],
+ [ '0.9.7f', '0.9.7e' ],
+ [ '10', '9' ],
+);
+
+my @equals = (
+ [ '1.0.0', '1.0.0' ],
+ [ '0.9Beta1', '0.9beta1' ],
+ [ '0.9beta1', '0.9 beta 1' ],
+ [ '0.3-alpha', '0.3_alpha' ],
+ [ '0.02', '.02' ],
+ [ '2.0.11', '15aug2000' ],
+ [ '2.0.11', '20060401' ],
+ [ '20', '20060401' ],
+);
+
+plan tests => 2 * @differents + 2 * @equals;
+
+foreach my $different (@differents) {
+ ok(
+ Youri::Check::Input::Updates::is_newer(
+ $different->[0],
+ $different->[1]
+ ),
+ "$different->[0] is newer as $different->[1]"
+ );
+ ok(
+ !Youri::Check::Input::Updates::is_newer(
+ $different->[1],
+ $different->[0]
+ ),
+ "$different->[1] is older as $different->[0]"
+ );
+}
+
+foreach my $equal (@equals) {
+ ok(
+ !Youri::Check::Input::Updates::is_newer(
+ $equal->[0],
+ $equal->[1]
+ ),
+ "$equal->[0] is equal as $equal->[1]"
+ );
+ ok(
+ !Youri::Check::Input::Updates::is_newer(
+ $equal->[1],
+ $equal->[0]
+ ),
+ "$equal->[1] is equal as $equal->[0]"
+ );
+}
Property changes on: build_system/mdv-youri-core/trunk/t/version.t
___________________________________________________________________
Added: svn:executable
+ *
-------------- next part --------------
An HTML attachment was scrubbed...
URL: </pipermail/mageia-sysadm/attachments/20110105/797a51f6/attachment-0001.html>
More information about the Mageia-sysadm
mailing list