1#line 1
2package Module::Install::Repository;
3
4use strict;
5use 5.005;
6use vars qw($VERSION);
7$VERSION = '0.06';
8
9use base qw(Module::Install::Base);
10
11sub _execute {
12    my ($command) = @_;
13    `$command`;
14}
15
16sub auto_set_repository {
17    my $self = shift;
18
19    return unless $Module::Install::AUTHOR;
20
21    my $repo = _find_repo(\&_execute);
22    if ($repo) {
23        $self->repository($repo);
24    } else {
25        warn "Cannot determine repository URL\n";
26    }
27}
28
29sub _find_repo {
30    my ($execute) = @_;
31
32    if (-e ".git") {
33        # TODO support remote besides 'origin'?
34        if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) {
35            # XXX Make it public clone URL, but this only works with github
36            my $git_url = $1;
37            $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
38            return $git_url;
39        } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) {
40            return $1;
41        }
42    } elsif (-e ".svn") {
43        if (`svn info` =~ /URL: (.*)$/m) {
44            return $1;
45        }
46    } elsif (-e "_darcs") {
47        # defaultrepo is better, but that is more likely to be ssh, not http
48        if (my $query_repo = `darcs query repo`) {
49            if ($query_repo =~ m!Default Remote: (http://.+)!) {
50                return $1;
51            }
52        }
53
54        open my $handle, '<', '_darcs/prefs/repos' or return;
55        while (<$handle>) {
56            chomp;
57            return $_ if m!^http://!;
58        }
59    } elsif (-e ".hg") {
60        if ($execute->('hg paths') =~ /default = (.*)$/m) {
61            my $mercurial_url = $1;
62            $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!;
63            return $mercurial_url;
64        }
65    } elsif (-e "$ENV{HOME}/.svk") {
66        # Is there an explicit way to check if it's an svk checkout?
67        my $svk_info = `svk info` or return;
68        SVK_INFO: {
69            if ($svk_info =~ /Mirrored From: (.*), Rev\./) {
70                return $1;
71            }
72
73            if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) {
74                $svk_info = `svk info /$1` or return;
75                redo SVK_INFO;
76            }
77        }
78
79        return;
80    }
81}
82
831;
84__END__
85
86=encoding utf-8
87
88#line 128
89