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