diff options
Diffstat (limited to 'lib/Youri/Repository')
-rw-r--r-- | lib/Youri/Repository/PLF.pm | 196 |
1 files changed, 196 insertions, 0 deletions
diff --git a/lib/Youri/Repository/PLF.pm b/lib/Youri/Repository/PLF.pm new file mode 100644 index 0000000..c260379 --- /dev/null +++ b/lib/Youri/Repository/PLF.pm @@ -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; |