aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Youri/Check/Input/Updates
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Youri/Check/Input/Updates')
-rw-r--r--lib/Youri/Check/Input/Updates/Source.pm240
-rw-r--r--lib/Youri/Check/Input/Updates/Source/CPAN.pm75
-rw-r--r--lib/Youri/Check/Input/Updates/Source/Debian.pm82
-rw-r--r--lib/Youri/Check/Input/Updates/Source/Fedora.pm63
-rw-r--r--lib/Youri/Check/Input/Updates/Source/Freshmeat.pm111
-rw-r--r--lib/Youri/Check/Input/Updates/Source/GNOME.pm104
-rw-r--r--lib/Youri/Check/Input/Updates/Source/Gentoo.pm75
-rw-r--r--lib/Youri/Check/Input/Updates/Source/NetBSD.pm75
-rw-r--r--lib/Youri/Check/Input/Updates/Source/RAA.pm121
-rw-r--r--lib/Youri/Check/Input/Updates/Source/Sourceforge.pm103
10 files changed, 1049 insertions, 0 deletions
diff --git a/lib/Youri/Check/Input/Updates/Source.pm b/lib/Youri/Check/Input/Updates/Source.pm
new file mode 100644
index 0000000..e81d4d5
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source.pm
@@ -0,0 +1,240 @@
+# $Id: Source.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source - Abstract updates source
+
+=head1 DESCRIPTION
+
+This abstract class defines the updates source interface for
+L<Youri::Check::Input::Updates>.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+
+=head1 CLASS METHODS
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates object.
+
+Generic parameters (subclasses may define additional ones):
+
+=over
+
+=item aliases $aliases
+
+Hash of package aliases.
+
+=back
+
+Warning: do not call directly, call subclass constructor instead.
+
+=cut
+
+sub new {
+ my $class = shift;
+ croak "Abstract class" if $class eq __PACKAGE__;
+
+ my %options = (
+ id => '', # object id
+ test => 0, # test mode
+ verbose => 0, # verbose mode
+ aliases => undef, # aliases
+ resolver => undef, # maintainer resolver
+ preferences => undef, # maintainer preferences
+ check_id => '', # parent check id
+ @_
+ );
+
+ if ($options{aliases}) {
+ croak "aliases should be an hashref" unless ref $options{aliases} eq 'HASH';
+ }
+ if ($options{resolver}) {
+ croak "resolver should be a Youri::Check::Maintainer::Resolver object" unless $options{resolver}->isa("Youri::Check::Maintainer::Resolver");
+ }
+ if ($options{preferences}) {
+ croak "preferences should be a Youri::Check::Maintainer::Preferences object" unless $options{preferences}->isa("Youri::Check::Maintainer::Preferences");
+ }
+
+ my $self = bless {
+ _id => $options{id},
+ _test => $options{test},
+ _verbose => $options{verbose},
+ _aliases => $options{aliases},
+ _resolver => $options{resolver},
+ _preferences => $options{preferences},
+ _check_id => $options{check_id},
+ }, $class;
+
+ $self->_init(%options);
+
+ return $self;
+}
+
+sub _init {
+ # do nothing
+}
+
+=head1 INSTANCE METHODS
+
+Excepted explicit statement, package name is expressed with Mandriva naming
+conventions.
+
+=head2 get_id()
+
+Returns source identity.
+
+=cut
+
+sub get_id {
+ my ($self) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return $self->{_id};
+}
+
+=head2 get_version($package)
+
+Returns available version for given package, which can be either a full
+L<Youri::Package> object or just a package name.
+
+=cut
+
+sub get_version {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name = ref $package && $package->isa('Youri::Package') ?
+ $package->get_canonical_name() :
+ $package;
+
+ # translate in grabber namespace
+ $name = $self->get_name($name);
+
+ # return if aliased to null
+ return unless $name;
+
+ # return subclass computation
+ return $self->_version($name);
+}
+
+=head2 get_url($name)
+
+Returns the URL of information source for package with given name.
+
+=cut
+
+sub get_url {
+ my ($self, $name) = @_;
+
+ # retun subclass computation
+ return $self->_url($self->get_name($name));
+}
+
+=head2 name($name)
+
+Returns name converted to specific source naming conventions for package with given name.
+
+=cut
+
+sub get_name {
+ my ($self, $name) = @_;
+ croak "Not a class method" unless ref $self;
+
+ # return config aliases if it exists
+ if ($self->{_aliases} ) {
+ return $self->{_aliases}->{$name} if exists $self->{_aliases}->{$name};
+ }
+
+ # return maintainer aliases if it exists
+ if ($self->{_resolver} && $self->{_preferences}) {
+ my $maintainer = $self->{_resolver}->get_maintainer($name);
+ if ($maintainer) {
+ my $aliases = $self->{_preferences}->get_preference(
+ $maintainer,
+ $self->{_check_id},
+ 'aliases'
+ );
+ if ($aliases) {
+ if ($aliases->{all}) {
+ return $aliases->{all}->{$name} if exists $aliases->{all}->{$name};
+ }
+ if ($aliases->{$self->{_id}}) {
+ return $aliases->{$self->{_id}}->{$name} if exists $aliases->{$self->{_id}}->{$name};
+ }
+ }
+ }
+ }
+
+ # return return subclass computation
+ return $self->_name($name);
+}
+
+=head2 _version($name)
+
+Hook called by default B<version()> implementation after name translation.
+
+=cut
+
+sub _version {
+ my ($self, $name) = @_;
+ return $self->{_versions}->{$name};
+}
+
+=head2 _url($name)
+
+Hook called by default B<url()> implementation after name translation.
+
+=cut
+
+sub _url {
+ my ($self, $name) = @_;
+ return undef;
+}
+
+=head2 _name($name)
+
+Hook called by default B<name()> implementation if given name was not found in
+the aliases.
+
+=cut
+
+sub _name {
+ my ($self, $name) = @_;
+ return $name;
+}
+
+=head1 SUBCLASSING
+
+The following methods have to be implemented:
+
+=over
+
+=item version
+
+As an alternative, the B<_version()> hook can be implemented.
+
+=item url
+
+As an alternative, the <_url()> hook can be implemented.
+
+=item name
+
+As an alternative, the B<_name()> hook can be implemented.
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/CPAN.pm b/lib/Youri/Check/Input/Updates/Source/CPAN.pm
new file mode 100644
index 0000000..cff1d29
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/CPAN.pm
@@ -0,0 +1,75 @@
+# $Id: CPAN.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::CPAN;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::CPAN - CPAN updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from CPAN.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::CPAN object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to CPAN full modules list (default:
+http://www.cpan.org/modules/01modules.index.html)
+
+=back
+
+=cut
+
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://www.cpan.org/modules/01modules.index.html',
+ @_
+ );
+
+ my $versions;
+ open(INPUT, "GET $options{url} |") or croak "Can't fetch $options{url}: $!";
+ while (<INPUT>) {
+ next unless $_ =~ />([\w-]+)-([\d\.]+)\.tar\.gz<\/a>/;
+ $versions->{$1} = $2;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://search.cpan.org/dist/$name";
+}
+
+sub _name {
+ my ($self, $name) = @_;
+ $name =~ s/^perl-//g;
+ return $name;
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/Debian.pm b/lib/Youri/Check/Input/Updates/Source/Debian.pm
new file mode 100644
index 0000000..24582a9
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/Debian.pm
@@ -0,0 +1,82 @@
+# $Id: Debian.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Debian;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Debian - Debian source for updates
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+ available from Debian.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Debian object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to Debian mirror content file (default: http://ftp.debian.org/ls-lR.gz)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://ftp.debian.org/ls-lR.gz',
+ @_
+ );
+
+ my $versions;
+ open(INPUT, "GET $options{url} | zcat |") or croak "Can't fetch $options{url}: $!";
+ while (my $line = <INPUT>) {
+ next unless $line =~ /([\w\.-]+)_([\d\.]+)\.orig\.tar\.gz$/;
+ my $name = $1;
+ my $version = $2;
+ $versions->{$name} = $version;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://packages.debian.org/$name";
+}
+
+sub _name {
+ my ($self, $name) = @_;
+
+ if ($name =~ /^(perl|ruby)-([-\w]+)$/) {
+ $name = lc("lib$2-$1");
+ } elsif ($name =~ /^apache-([-\w]+)$/) {
+ $name = "libapache-$1";
+ $name =~ s/_/-/g;
+ }
+
+ return $name;
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/Fedora.pm b/lib/Youri/Check/Input/Updates/Source/Fedora.pm
new file mode 100644
index 0000000..cb74d36
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/Fedora.pm
@@ -0,0 +1,63 @@
+# $Id: Fedora.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Fedora;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Fedora - Fedora updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Fedora.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Fedora object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to Fedora development SRPMS directory (default:
+http://fr.rpmfind.net/linux/fedora/core/development/SRPMS)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://fr.rpmfind.net/linux/fedora/core/development/SRPMS',
+ @_
+ );
+
+ my $versions;
+ open(INPUT, "GET $options{url} |") or die "Can't fetch $options{url}: $!\n";
+ while (<INPUT>) {
+ next unless $_ =~ />([\w-]+)-([\w\.]+)-[\w\.]+\.src\.rpm<\/a>/;
+ $versions->{$1} = $2;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm b/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm
new file mode 100644
index 0000000..9e9b7ce
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/Freshmeat.pm
@@ -0,0 +1,111 @@
+# $Id: Freshmeat.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Freshmeat;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Freshmeat - Freshmeat source for updates
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Freshmeat.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use XML::Twig;
+use LWP::UserAgent;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Freshmeat
+object.
+
+Specific parameters:
+
+=over
+
+=item preload true/false
+
+Allows to load full Freshmeat catalogue at once instead of checking each software independantly (default: false)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ preload => 0,
+ @_
+ );
+
+ if ($options{preload}) {
+ my $versions;
+
+ my $project = sub {
+ my ($twig, $project) = @_;
+ my $name = $project->first_child('projectname_short')->text();
+ my $version = $project->first_child('latest_release')->first_child('latest_release_version')->text();
+ $versions->{$name} = $version;
+ $twig->purge();
+ };
+
+ my $twig = XML::Twig->new(
+ TwigRoots => { project => $project }
+ );
+
+ my $url = 'http://download.freshmeat.net/backend/fm-projects.rdf.bz2';
+
+ open(INPUT, "GET $url | bzcat |") or die "Can't fetch $url: $!\n";
+ $twig->parse(\*INPUT);
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+ }
+}
+
+sub _version {
+ my ($self, $name) = @_;
+
+ if ($self->{_versions}) {
+ return $self->{_versions}->{$name};
+ } else {
+ my $version;
+
+ my $latest_release_version = sub {
+ $version = $_[1]->text();
+ };
+
+ my $twig = XML::Twig->new(
+ TwigRoots => { latest_release_version => $latest_release_version }
+ );
+
+ my $url = "http://freshmeat.net/projects-xml/$name";
+
+ open(INPUT, "GET $url |") or die "Can't fetch $url: $!\n";
+ # freshmeat answer with an HTML page when project doesn't exist
+ $twig->safe_parse(\*INPUT);
+ close(INPUT);
+
+ return $version;
+ }
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://freshmeat.net/projects/$name";
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/GNOME.pm b/lib/Youri/Check/Input/Updates/Source/GNOME.pm
new file mode 100644
index 0000000..381ae5e
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/GNOME.pm
@@ -0,0 +1,104 @@
+# $Id$
+package Youri::Check::Input::Updates::Source::GNOME;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::GNOME - GNOME updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from GNOME.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use LWP::UserAgent;
+use HTML::TokeParser;
+use List::MoreUtils 'any';
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Gnome object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to GNOME sources directory (default:
+http://fr2.rpmfind.net/linux/gnome.org/sources)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://fr2.rpmfind.net/linux/gnome.org/sources/', # default url
+ # We use HTTP as it offers a better sorting (1.2 < 1.10)
+ @_
+ );
+
+ $self->{_agent} = LWP::UserAgent->new();
+ my $response = $self->{_agent}->get($options{url});
+ if($response->is_success()) {
+ my $parser = HTML::TokeParser->new(\$response->content());
+ while (my $token = $parser->get_tag('a')) {
+ my $href = $token->[1]->{href};
+ next unless $href =~ /^([-\w]+)\/$/o;
+ $self->{_names}->{$1} = 1;
+ }
+ }
+
+ $self->{_url} = $options{url};
+}
+
+sub _version {
+ my ($self, $name) = @_;
+ croak "Not a class method" unless ref $self;
+
+ return unless $self->{_names}->{$name};
+
+ my $response = $self->{_agent}->get("$self->{_url}/$name/");
+ if($response->is_success()) {
+ my $major;
+ my $parser = HTML::TokeParser->new(\$response->content());
+ while (my $token = $parser->get_tag('a')) {
+ my $href = $token->[1]->{href};
+ next unless $href =~ /^([.\d]+)\/$/o;
+ $major = $1;
+ }
+ return unless $major;
+
+ $response = $self->{_agent}->get("$self->{_url}/$name/$major/");
+ if($response->is_success()) {
+ $parser = HTML::TokeParser->new(\$response->content());
+ while (my $token = $parser->get_tag('a')) {
+ my $href = $token->[1]->{href};
+ next unless $href =~ /^LATEST-IS-([.\d]+)$/o;
+ return $1;
+ }
+ }
+ }
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return $self->{_url}."$name/";
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/Gentoo.pm b/lib/Youri/Check/Input/Updates/Source/Gentoo.pm
new file mode 100644
index 0000000..de8f376
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/Gentoo.pm
@@ -0,0 +1,75 @@
+# $Id: Gentoo.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Gentoo;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Gentoo - Gentoo updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Gentoo.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use LWP::Simple;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Gentoo object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to Gentoo snapshots directory (default:
+http://gentoo.mirror.sdv.fr/snapshots)
+
+=back
+
+=cut
+
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://gentoo.mirror.sdv.fr/snapshots', # default URL
+ @_
+ );
+
+ my $versions;
+ my $content = get($options{url});
+ my $file;
+ while ($content =~ /<A HREF="(portage-\d{8}.tar.bz2)">/g) {
+ $file = $1;
+ }
+ open(INPUT, "GET $options{url}/$file | tar tjf - |") or croak "Can't fetch $options{url}/$file: $!";
+ while (my $line = <INPUT>) {
+ next unless $line =~ /.*\/([\w-]+)-([\d\.]+)(:?-r\d)?\.ebuild$/;
+ $versions->{$1} = $2;
+ }
+ close(INPUT);
+
+ $self->{_versions} = $versions;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://packages.gentoo.org/search/?sstring=$name";
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/NetBSD.pm b/lib/Youri/Check/Input/Updates/Source/NetBSD.pm
new file mode 100644
index 0000000..5142001
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/NetBSD.pm
@@ -0,0 +1,75 @@
+# $Id$
+package Youri::Check::Input::Updates::Source::NetBSD;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::NetBSD - NetBSD source for updates
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+ available from NetBSD.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use base 'Youri::Check::Input::Updates::Source';
+use IO::Ftp;
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::NetBSD object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to NetBSD mirror content file, without ftp: (default: //ftp.free.fr/mirrors/ftp.netbsd.org/NetBSD-current/pkgsrc/README-all.html)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => '//ftp.free.fr/mirrors/ftp.netbsd.org/NetBSD-current/pkgsrc/README-all.html',
+ @_
+ );
+
+ my $versions;
+ my $urls;
+
+ my $in = IO::Ftp->new('<',$options{url}) or croak "Can't fetch $options{url}: $!";
+ while (my $line = <$in>) {
+ next unless $line =~ /<!-- (.+)-([^-]*?)(nb\d*)? \(for sorting\).*?href="([^"]+)"/;
+ my $name = $1;
+ my $version = $2;
+ $versions->{$name} = $version;
+ $urls->{$name} = $4;
+ }
+ close($in);
+
+ $self->{_versions} = $versions;
+ $self->{_urls} = $urls;
+ $self->{_url} = $options{url};
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return $self->{_urls}->{$name};
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/RAA.pm b/lib/Youri/Check/Input/Updates/Source/RAA.pm
new file mode 100644
index 0000000..2e7356e
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/RAA.pm
@@ -0,0 +1,121 @@
+# $Id: RAA.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::RAA;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::RAA - RAA updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from RAA.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use SOAP::Lite;
+use List::MoreUtils 'any';
+use Youri::Package;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::RAA object.
+
+Specific parameters:
+
+=over
+
+=item url $url
+
+URL to RAA SOAP interface (default:
+http://www.ruby-lang.org/xmlns/soap/interface/RAA/0.0.4)
+
+=back
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ url => 'http://www.ruby-lang.org/xmlns/soap/interface/RAA/0.0.4/',
+ @_
+ );
+
+ my $raa = SOAP::Lite->service($options{url})
+ or croak "Can't connect to $options{url}";
+
+ $self->{_raa} = $raa;
+ $self->{_names} = $raa->names();
+}
+
+sub get_version {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name;
+ if (ref $package && $package->isa('Youri::Package')) {
+ # don't bother checking for non-ruby packages
+ if (
+ any { $_->[Youri::Package::DEPENDENCY_NAME] =~ /ruby/ }
+ $package->get_requires()
+ ) {
+ $name = $package->get_canonical_name();
+ } else {
+ return;
+ }
+ } else {
+ $name = $package;
+ }
+
+ # translate in grabber namespace
+ $name = $self->get_name($name);
+
+ # return if aliased to null
+ return unless $name;
+
+ # susceptible to throw exception for timeout
+ eval {
+ my $gem = $self->{_raa}->gem($name);
+ return $gem->{project}->{version} if $gem;
+ };
+
+ return;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://raa.ruby-lang.org/project/$name/";
+}
+
+sub _name {
+ my ($self, $name) = @_;
+
+ if (ref $self) {
+ my $match = $name;
+ $match =~ s/^ruby[-_]//;
+ $match =~ s/[-_]ruby$//;
+ my @results =
+ grep { /^(ruby[-_])?\Q$match\E([-_]ruby)$/ }
+ @{$self->{_names}};
+ if (@results) {
+ return $results[0];
+ } else {
+ return $name;
+ }
+ } else {
+ return $name;
+ }
+}
+
+=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;
diff --git a/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm b/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm
new file mode 100644
index 0000000..7623b3b
--- /dev/null
+++ b/lib/Youri/Check/Input/Updates/Source/Sourceforge.pm
@@ -0,0 +1,103 @@
+# $Id: Sourceforge.pm 1179 2006-08-05 08:30:57Z warly $
+package Youri::Check::Input::Updates::Source::Sourceforge;
+
+=head1 NAME
+
+Youri::Check::Input::Updates::Source::Sourceforge - Sourceforge updates source
+
+=head1 DESCRIPTION
+
+This source plugin for L<Youri::Check::Input::Updates> collects updates
+available from Sourceforge.
+
+=cut
+
+use warnings;
+use strict;
+use Carp;
+use LWP::UserAgent;
+use HTML::TokeParser;
+use Youri::Check::Input::Updates;
+use base 'Youri::Check::Input::Updates::Source';
+
+=head2 new(%args)
+
+Creates and returns a new Youri::Check::Input::Updates::Source::Sourceforge
+object.
+
+No specific parameters.
+
+=cut
+
+sub _init {
+ my $self = shift;
+ my %options = (
+ @_
+ );
+
+ $self->{_agent} = LWP::UserAgent->new();
+}
+
+sub get_version {
+ my ($self, $package) = @_;
+ croak "Not a class method" unless ref $self;
+
+ my $name;
+ if (ref $package && $package->isa('Youri::Package')) {
+ # don't bother checking for packages without sf.net URL
+ my $url = $package->get_url();
+ if (
+ $url =~ /http:\/\/(.*)\.sourceforge\.net/ ||
+ $url =~ /http:\/\/.*sourceforge\.net\/projects\/([^\/]+)/
+ ) {
+ $name = $package->get_canonical_name();
+ } else {
+ return;
+ }
+ } else {
+ $name = $package;
+ }
+
+ # translate in grabber namespace
+ $name = $self->get_name($name);
+
+ # return if aliased to null
+ return unless $name;
+
+ my $response = $self->{_agent}->get($self->_url($name));
+ if($response->is_success()) {
+ my $max = 0;
+ my $parser = HTML::TokeParser->new(\$response->content());
+ while (my $token = $parser->get_tag('a')) {
+ my $text = $parser->get_trimmed_text("/$token->[0]");
+ next unless $text;
+ next unless $text =~ /^
+ \Q$name\E
+ [._-]?($Youri::Check::Input::Updates::VERSION_REGEXP)
+ [._-]?(w(?:in)?(?:32)?|mips|sparc|bin|ppc|i\d86|src|sources?)?
+ \.(?:tar\.(?:gz|bz2)|tgz|zip)
+ $/iox;
+ my $version = $1;
+ my $arch = $2;
+ next if $arch && $arch !~ /(src|sources?)/;
+ $max = $version if Youri::Check::Input::Updates::is_newer($version, $max);
+ }
+ return $max if $max;
+ }
+ return;
+}
+
+sub _url {
+ my ($self, $name) = @_;
+ return "http://prdownloads.sourceforge.net/$name/";
+}
+
+=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;
generated by cgit v1.2.1 (git 2.21.0) at 2024-05-22 09:10:03 +0000