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