search in core, nonfree, tainted instead of main, contrib

1 files changed, 492 insertions, 0 deletions

diff --git a/lib/Youri/Repository.pm b/lib/Youri/Repository.pm
new file mode 100644
index 0000000..bbc6178
--- /dev/null
+++ b/lib/Youri/Repository.pm
@@ -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;