cpanflute2_wrapper.pl

#!/usr/bin/perl

use strict;
use warnings;
use Getopt::Long;
use LWP::Simple;
use File::Temp qw(tempdir);
use Archive::Tar;
use YAML;
use IPC::Run3;

my @doc_modules = qw( Catalyst::Manual );

my %use_module_mapping = (
    'Module::Install' => 'inc::Module::Install',
);

GetOptions(
    \my %options, "outdir=s", "tmpdir=s", "email=s", "name|n=s", "create",
    "test|t", "epoch|e=n", "version|v=s", "release|r=s", "patch=s@",
    "noarch", "arch|a=s", "noperlreqs", "usage", "buildall|b", "installdirs=s",
    "descfile=s", "help", "requires=s@", "buildrequires=s@", "sign", "post=s",
    "pre=s", "preun=s", "postun=s", "just-spec|j", 'use-usr-local', 'packager',
);

my $module = shift;

my $log_level = $options{'log-level'} || 'info';
my $tmpdir = tempdir( CLEANUP => 1, DIR => $options{tmpdir} || '/tmp' );

my @modules_to_build = ( { name => $module, version => $options{version} } );

delete $options{version};

while ( my $mod = shift @modules_to_build ) {
    build_module( $mod->{name}, $mod->{version} );
}

sub build_module {
    my ( $module, $version ) = @_;

    my $tarball   = get_file_from_cpan_web($module, $version);
    return unless $tarball;

    my $resolved = resolve_dependencies($tarball);

    if ( $resolved ) {
        my $opts = join ' ', map {
            do {
                if ( $options{$_} == 1 ) {
                    "--$_";
                }
                else {
                    "--$_=$options{$_}"
                }
            }
        } keys %options;

        print_log( info => "cpanflute2 $opts $tmpdir/$tarball" );
        system "cpanflute2 $opts $tmpdir/$tarball";
        unless ( $? ) {
            my $package = get_package_name($module);
            $package = "perl-$package";
            my @rpms = glob("$package*.rpm");
            for my $rpm ( @rpms ) {
                next if $rpm =~ /src\.rpm/;
                `sudo rpm -Uvh $rpm`;
            }
        }
   }
    else {
        push @modules_to_build,{ name => $module, version => $version };
    }
}

sub get_file_from_cpan_web {
    my ( $module, $version ) = @_;

    my $tarball_url = get_tarball_url($module, $version);

    my ($loc, $file) = $tarball_url =~ m|(.*)/(.*)|;
    print_log( info => "Getting $file ...");
    mirror($tarball_url, "$tmpdir/$file");

    return $file;
}

sub get_tarball_url {
    my ( $module, $version ) = @_;

    my $base   = "http://search.cpan.org";
    my $url    = "$base/dist/$module";
    $url       =~ s/::/-/g;
    $url      .= "-$version" if $version;

    local $_ = LWP::Simple::get($url) || return;
    m% \<a[^<>]*         # Begin Anchor tag
       href\s*=\s*       # href parameter
       (['"]?)           # Maybe quote
       ([^<>\s"']*)      # Extract link as $2
       \1                # Maybe quote
       [^<>]*\>          # End Anchor tag
       \s*Download       # of the "Download" link
     %ix;                # case insensitive HTML

    my $tarball_url = "$base$2" if $2;

    unless ( $2 ) {
        my $package = get_package_name($module);
        $tarball_url = get_tarball_url($package);
    }

    die "$module not found on CPAN web site!"
        unless $tarball_url;

    return $tarball_url;
}

sub resolve_dependencies {
    my $tarball = shift;

    my @files = Archive::Tar->list_archive("$tmpdir/$tarball");
    my $use_module_build = 1 if grep { /Build\.PL$/ } @files;

    my $resolved = 1;
    my %prefixes;
    foreach (@files) {
        my @path_components = split m[/], $_;
        $prefixes{$path_components[0]}++;
        if ($path_components[-1] eq 'META.yml') {
            my $tar = new Archive::Tar;
            $tar->read("$tmpdir/$tarball", 1);
            my $contents = $tar->get_content($_);
            my $yaml = YAML::Load($contents);

            while (my ($mod, $ver) = each %{$yaml->{build_requires}}) {
                next if $mod eq 'perl';
                unless ( install_package($mod, $ver) ) {
                    push @modules_to_build, { name => $mod, version => 0 };
                    $resolved = 0;
                }
            }

            while (my ($mod, $ver) = each %{$yaml->{requires}}) {
                next if $mod eq 'perl';
                unless ( install_package($mod, $ver) ) {
                    push @modules_to_build, { name => $mod, version => 0 };
                    $resolved = 0;
                }
            }
            while (my ($mod, $ver) = each %{$yaml->{recommends}}) {
                next if $mod eq 'perl';
                unless ( install_package($mod, $ver) ) {
                    push @modules_to_build, { name => $mod, version => 0 };
                    $resolved = 0;
                }
            }
        }
    }

    return $resolved;
}

sub install_package {
    my ( $module, $version ) = @_;

    $module = $use_module_mapping{$module} if $use_module_mapping{$module};

    # モジュールが存在するかチェック
    if ( grep { $module eq $_ } @doc_modules ) {
        `perldoc -l $module`;
        return 1 unless $?;
    }
    else {
        print_log( info => "Checking $module $version'" );
        my $check = check_module_and_version( $module, $version );
        # 存在するなら return
        return 1 if $check;
    }

    print_log( info => "Required module $module $version not found" );

    my $package = get_package_name($module);
    $package = "perl-$package";

    # パッケージが存在するかチェック
    `rpm -q $package`;

    # 存在する場合は yum update してみる
    unless ( $? ) {
        print_log( info => "Trying to update a required package $package ...");
        run3("sudo yum update -y $package", \my $in, \my $out, \my $err);
        print_log( 'debug' => $out );

        if ( $out =~ /no packages marked for update/i ) {
            # update できなかったら 0 で treturn
            print_log( error => "Failed to update $package");
            return 0;
        }
        else {
            # もう一度モジュール存在チェック
            print_log( info => "Succeeded to update $package");
            my $check = check_module_and_version( $module, $version );
            return 1 if $check;
        }
    }
    else {
        # 存在しなければパッケージインストールしてみる
        print_log( info => "Trying to install a required package $package ...");
        run3("sudo yum install -y $package", \my $in, \my $out, \my $err);
        print_log( 'debug' => $out );
        if ( $out =~ /Nothing to do/ ) {
            print_log( error => "Failed to install $package");
            return 0;
        }
        else {
            print_log( info => "Succeeded to install $package");
            return 1;
        }
    }
}

sub get_package_name {
    my $module = shift;

    my $content = get("http://search.cpan.org/search?query=$module") || return;
    my ( $package ) = ( $content =~ m!href="/~[^/]+/([^/]+)/"! );
    $package =~ s/-[^-]+$//;
    return $package;
}

# ログ表示用のルーチン
sub print_log {
    my( $level, $msg ) = @_;
    return unless should_log($level);
    chomp($msg);
    warn "[$level] $msg\n";
}

sub should_log {
    my $level = shift;

    my %levels = (
        debug => 0,
        warn  => 1,
        info  => 2,
        error => 3,
    );

    $levels{$level} >= $levels{$log_level};
}

sub check_module_and_version {
    # code from ExtUtils::MakeMaker
    my ( $module, $version ) = @_;

    my $file = "${module}.pm";
    $file =~ s{::}{/}g;
    eval { require $file };

    my $pr_version = $module->VERSION || 0;

    # convert X.Y_Z alpha version #s to X.YZ for easier comparisons
    $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/;

    if ( $@ or $pr_version < $version ) {
        return 0;
    }

    return 1;
}