1 files changed, 71 insertions, 0 deletions
diff --git a/lib/Youri/Submit/Test/ACL.pm b/lib/Youri/Submit/Test/ACL.pm
new file mode 100644
index 0000000..34bf48a
--- /dev/null
+++ b/lib/Youri/Submit/Test/ACL.pm
@@ -0,0 +1,71 @@
+# $Id$
+package Youri::Submit::Check::ACL;
+
+=head1 NAME
+
+Youri::Submit::Check::Tag - Incorrect tag values check
+
+=head1 DESCRIPTION
+
+This check plugin rejects packages with incorrect tag values, based on regular
+expressions.
+
+=cut
+
+use strict;
+use Carp;
+use base qw/Youri::Submit::Check/;
+my $acl;
+
+sub _init {
+    my $self   = shift;
+    my %options = (
+	acl_file => '',
+        @_
+    );
+    $acl = get_acl($options{acl_file});
+}
+
+sub run {
+    my ($self, $package, $repository, $target, $define) = @_;
+    croak "Not a class method" unless ref $self;
+    my $file = $package->get_full_name();
+    my $arch = $package->get_arch();
+    my $srpm = $package->get_canonical_name;
+    my $section = $repository->_get_section($package, $target, $define);
+    my $user = $define->{user};
+    foreach my $t (keys %$acl) {
+	next if $target !~ /$t/;
+	foreach my $acl (@{$acl->{$t}}) {
+	    my ($a, $media, $r, $users) = @$acl;
+	    next if $arch !~ $a || $srpm !~ $r || $section !~ $media;
+	    if ($user =~ /$users/) {
+		return 
+	    } else { 
+		return "$user is not authorized to upload packages belonging to $srpm in section $section (authorized persons: " . join(', ', split '\|',  $users) . ")";
+	    }
+	}
+    }
+    return
+}
+
+sub get_acl {
+    my ($file) = @_;
+    my %acl;
+    open my $f, $file;
+    while (<$f>) { 
+	my ($dis, $arch, $media, $regexp, $users) = split ' ';
+	push @{$acl{$dis}}, [ $arch , $media, $regexp, $users ]
+    }
+    \%acl
+}
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002-2006, YOURI project
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1;