view release on metacpan or  search on metacpan

lib/App/EUMM/Upgrade.pm  view on Meta::CPAN

sub add_new_fields {
  my $content = shift;
  my $new_fields = shift;
  my $text2replace = 'WriteMakefile\(';
  if ($content =~ /WriteMakefile\(\s*(\%\w+)\s*\);/) {
    my $var_params = $1;
    $text2replace = qr/$var_params\s*=\s*\(\s*$/m;
    $content =~ s/($text2replace)/$1$new_fields/ or die "Cannot find $var_params initialization in Makefile.PL";
    $content =~ s/WriteMakefile\s*\(/WriteMakefile(/s;
  } else {
    $content =~ s/WriteMakefile\s*\(/WriteMakefile($new_fields/s;
  }
  return $content;
}



#_find_repo copied from Module::Install::Repository;
#by Tatsuhiko Miyagawa
#See Module::Install::Repository for copyright

sub _execute {
    my ($command) = @_;
    local $ENV{LC_ALL} = "C";
    `$command`;
}

sub find_repo {
  return _find_repo(\&_execute);
}

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

    if (-e ".git") {
        # TODO support remote besides 'origin'?
        my $git_url =  '';
        if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) {
            # XXX Make it public clone URL, but this only works with github
            $git_url = $1;
            $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
            return ('git', $git_url);
        } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) {
            $git_url = $1;
        }
        return '' if $git_url =~ /\A\w+\z/;# invalid github remote might come back with just the remote name
        return ('git', $git_url);
    } elsif (-e ".svn") {
        if ($execute->('svn info') =~ /URL: (.*)$/m) {
            return ('svn', $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 ('darcs', $1);
            }
        }

        open my $handle, '<', '_darcs/prefs/repos' or return;
        while (<$handle>) {
            chomp;
            return ('darcs', $_) 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 ('hg', $mercurial_url);
        }
    } elsif ($ENV{HOME} && -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 ('svk', $1);
            }

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

        return;
    }
}

sub convert_url_to_public {
  my $url = shift;
  $url =~ s#^(?:ssh://|git://)?git\@(github\.com|bitbucket\.org)[:/]#https://$1/# and return $url;
  #ssh://git@bitbucket.org/shlomif/fc-solve.git

  $url =~ s#^(?:ssh://)hg\@(bitbucket\.org)/#https://$1/# and return $url;
  #ssh://hg@bitbucket.org/shlomif/app-notifier

  $url =~ s#^https://(\w+)\@(bitbucket\.org)/#https://$2/# and return $url;
  #ssh://hg@bitbucket.org/shlomif/app-notifier

  return $url;
}    

sub convert_url_to_web {
  my $url = shift;
  return unless $url;
  $url =~ s#^(?:https?|git)://(github\.com|bitbucket\.org)/(.*)\.git#https://$1/$2# and return $url;
  $url =~ s#^https?://(bitbucket\.org)/(.*)#https://$1/$2# and return $url;
  return;
}

1; # End of App::EUMM::Upgrade