File Coverage

blib/lib/Module/Install/Repository.pm

Criterion	Covered	Total	%
statement	11	50	22.0
branch	0	38	0.0
condition	0	3	0.0
subroutine	4	7	57.1
pod	0	1	0.0
total	15	99	15.1

package Module::Install::Repository;

use strict;
use 5.005;
use vars qw($VERSION);
$VERSION = '0.08';

use base qw(Module::Install::Base);

sub _execute {
    my ($command) = @_;
    `$command`;
}

sub auto_set_repository {
    my $self = shift;

    return unless $Module::Install::AUTHOR;

    my $repo = _find_repo(\&_execute);
    if ($repo) {
        $self->repository($repo);
    } else {
        warn "Cannot determine repository URL\n";
    }
}

sub _find_repo {
    my ($execute) = @_;

    if (-e ".git") {
        foreach my $name (qw(origin github)) {
            my $git_output = $execute->("git remote show -n $name");
            if ($git_output =~ /Tracked remote branch/ && $git_output =~ /URL: (.*)$/m) {
                # XXX Make it public clone URL, but this only works with github
                my $git_url = $1;
                $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
                return $git_url;
            }
        }

        if ($execute->('git svn info') =~ /URL: (.*)$/m) {
            return $1;
        }
    } elsif (-e ".svn") {
        if (`svn info` =~ /URL: (.*)$/m) {
            return $1;
        }
    } elsif (-e "_darcs") {
        # defaultrepo is better, but that is more likely to be ssh, not http
        if (my $query_repo = `darcs query repo`) {
            if ($query_repo =~ m!Default Remote: (http://.+)!) {
                return $1;
            }
        }

        open my $handle, '<', '_darcs/prefs/repos' or return;
        while (<$handle>) {
            chomp;
            return $_ if m!^http://!;
        }
    } elsif (-e ".hg") {
        if ($execute->('hg paths') =~ /default = (.*)$/m) {
            my $mercurial_url = $1;
            $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!;
            return $mercurial_url;
        }
    } elsif (-e "$ENV{HOME}/.svk") {
        # Is there an explicit way to check if it's an svk checkout?
        my $svk_info = `svk info` or return;
        SVK_INFO: {
            if ($svk_info =~ /Mirrored From: (.*), Rev\./) {
                return $1;
            }

            if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) {
                $svk_info = `svk info /$1` or return;
                redo SVK_INFO;
            }
        }

        return;
    }
}

1;
__END__