diff options
Diffstat (limited to 'lib/Youri/Repository.pm')
| -rw-r--r-- | lib/Youri/Repository.pm | 492 |
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; |