@${CP} ${FILESDIR}/files-Portscout-SiteHandler-CPAN.pm ${WRKSRC}/Portscout/SiteHandler/CPAN.pm

#------------------------------------------------------------------------------

# Copyright (C) 2017, Andrej Zverev <az@FreeBSD.org>

# All rights reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions

# are met:

# 1. Redistributions of source code must retain the above copyright

#    notice, this list of conditions and the following disclaimer.

# 2. Redistributions in binary form must reproduce the above copyright

#    notice, this list of conditions and the following disclaimer in the

#    documentation and/or other materials provided with the distribution.

#

# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND

# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE

# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE

# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS

# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)

# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF

# SUCH DAMAGE.

#

#------------------------------------------------------------------------------

package Portscout::SiteHandler::CPAN;

use Portscout::Const;

use Portscout::Config;

use strict;

require 5.006;

#------------------------------------------------------------------------------

# Globals

#------------------------------------------------------------------------------

push @Portscout::SiteHandler::sitehandlers, __PACKAGE__;

our %settings;

# All CPAN mirrors including CPAN mastersite itself have same directory hierarchy 

# and these two regex are to match all cases

# At least check if URLs are HTTP (no HTTPS yet) or FTP.

my @CPAN_SITES = (

	"(http|ftp):\/\/.*/modules/by-module/",

	"(http|ftp):\/\/.*/authors/id/",

);

#------------------------------------------------------------------------------

# Func: new()

# Desc: Constructor.

#

# Args: n/a

#

# Retn: $self

#------------------------------------------------------------------------------

sub new

{

	my $self      = {};

	my $class     = shift;

	$self->{name} = 'CPAN';

	bless ($self, $class);

	return $self;

}

#------------------------------------------------------------------------------

# Func: CanHandle()

# Desc: Ask if this handler (package) can handle the given site.

#

# Args: $url - URL of site.

#

# Retn: $res - true/false.

#------------------------------------------------------------------------------

sub CanHandle

{

	my $self = shift;

	my ($url) = @_;

	my $result = 0;

	# Do check if 02packages.details.txt is exist inside tmpdir, otherwise fallback 

	# to normal portscout's proccessing logic.

	# Normaly you can find at this URL: www.cpan.org/modules/02packages.details.txt

	# and re-download it daily via cron task. Not hard at all.

	unless (is_CacheFound()) {

		_debug("Cache: 02packages.details.txt is not found, fallback");

		return 0;

	}

	foreach my $site (@CPAN_SITES) {

		# Stop processing after first match.

		$result = $url =~ /$site/;

		if ($result) {

			_debug("URL: $url is matched with $site");

			return 1;

		}

	}

	return 0;

}

#------------------------------------------------------------------------------

# Func: GetFiles()

# Desc: Extract a list of files from the given URL. In the case of SourceForge,

#       we are actually pulling the files from an RSS feed helpfully provided

#       for each "project".

#

# Args: $url     - URL we would normally fetch from.

#       \%port   - Port hash fetched from database.

#       \@files  - Array to put files into.

#

# Retn: $success - False if file list could not be constructed; else, true.

#------------------------------------------------------------------------------

sub GetFiles

{

	my $self = shift;

	my ($url, $port, $files) = @_;

	my $cachefile = GetCacheLocation();

	# Reading file everytime must be not very expensive, since after a first 

	# read that file is placed inside FreeBSD VM cache.

	open (my $cf, "< $cachefile") or return 0;

	# Take distfile name and remove version part from it.

	# Rex-1.2.1.tar.gz -> Rex-*.tar.gz

	# Such regexp will match not exaclty required distfile, but we

	# don't care here, since portscout will solve other things for us.

	# Also we don't care about duplicates.

	my $distfile = $port->{'distfiles'};

	$distfile =~ s/$port->{'ver'}/.*/;

	while (my $line = <$cf>) {

		if ($line =~ /$distfile/) {

			my $module_path = (split(' ', $line))[2];

			push @$files, "authors/id/$module_path";

			_debug("Path: $module_path is found");

		}

	}

	close ($cf);

	return 1;

}

#------------------------------------------------------------------------------

## Func: GetCacheLocation()

## Desc: Return full path for 02packages.details.txt.

##

## Args: n/a.

##

## Retn: $location

##------------------------------------------------------------------------------

sub GetCacheLocation {

	my $location = sprintf("%s/02packages.details.txt", $settings{tmpdir});

	return $location;

}

#------------------------------------------------------------------------------

## Func: is_CacheFound()

## Desc: Check is 02packages.details.txt is available

##

## Args: n/a.

##

## Retn: true - if found, false is not found

##------------------------------------------------------------------------------

sub is_CacheFound

{

	my $location = GetCacheLocation();

	return 1 if (-e $location); 

	return 0;

}

#------------------------------------------------------------------------------

# Func: _debug()

# Desc: Print a debug message.

#

# Args: $msg - Message.

#

# Retn: n/a

#------------------------------------------------------------------------------

sub _debug

{

	my ($msg) = @_;

	$msg = '' if (!$msg);

	print STDERR "(SiteHandler::SourceForge) $msg\n"

		if ($settings{debug});

}

1;

+use Portscout::SiteHandler::CPAN;

+

+# CPAN site handler howto:

+# Download http://www.cpan.org/modules/02packages.details.txt into tmpdir

+# and create cron task to re-download it on daily basis.

%%SITE_PERL%%/Portscout/SiteHandler/CPAN.pm