File Coverage

blib/lib/Git/DescribeVersion.pm

Criterion	Covered	Total	%
statement	92	105	87.6
branch	36	44	81.8
condition	14	27	51.8
subroutine	16	16	100.0
pod	7	11	63.6
total	165	203	81.2

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of Git-DescribeVersion
#
# This software is copyright (c) 2010 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package Git::DescribeVersion;
{
  $Git::DescribeVersion::VERSION = '1.015';
}
# git description: v1.014-6-g81d7192

BEGIN {
  $Git::DescribeVersion::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Use git-describe to show a repo's version

use Carp (); # core
use version 0.82 ();

our %Defaults = (
  first_version   => 'v0.1',
  match_pattern   => 'v[0-9]*',
  format      => 'decimal',
  version_regexp  => '([0-9._]+)'
);

# Git::Repository is easier to install than Git::Wrapper
my @delegators = qw(
  git_repository
  git_wrapper
  git_backticks
);


sub new {
  my $class = shift;
  # accept a hash or hashref
  my %opts = ref($_[0]) ? %{$_[0]} : @_;
  my $self = {
    %Defaults,
    # restrict accepted arguments
    map { $_ => $opts{$_} } grep { exists($opts{$_}) } keys %Defaults
  };

  $self->{directory} = $opts{directory} || '.';
  bless $self, $class;

  # accept a Git::Repository or Git::Wrapper object (or command to exec)
  # or a simple '1' (true value) to indicate which one is desired
  foreach my $mod ( @delegators ){
    if( $opts{$mod} ){
      $self->{git} = $mod;
      # if it's just a true value leave it blank so we create later
      # TODO: should this be checking ref?
      $self->{$mod} = $opts{$mod}
        unless $opts{$mod} eq '1';
      # test that requested method "works"
      eval { $self->$mod('--version') };
      if( $@ ){
        Carp::carp qq[Failed to execute $mod (will attempt other methods): $@];
        delete @$self{(git => $mod)};
      }
    }
  }
  return $self;
}


sub format_version {
  my ($self, $vobject) = @_;
  my $format = $self->{format} =~ /dot|normal|v|string/ ? 'normal' : 'numify';
  my $version = $vobject->$format;
  $version =~ s/^v// if $self->{format} =~ /no.?v/;
  return $version;
}


# NOTE: the git* subs are called in list context

sub git {
  my ($self) = @_;
  unless( $self->{git} ){
    for my $method ( @delegators ){
      $self->{git} ||= eval {
        # confirm method works (without dying)
        $self->$method('--version');
        $method;
      };
    }
    Carp::croak("All git methods failed.  Is `git` installed?\n".
      "Consider installing Git::Repository or Git::Wrapper.\n")
      unless $self->{git};
  }
  goto &{$self->{git}};
}

sub git_backticks {
  my ($self, $command, @args) = @_;
  warn("'directory' attribute not supported when using backticks.\n" .
    "Consider installing Git::Repository or Git::Wrapper.\n")
      if $self->{directory} && $self->{directory} ne '.';

  @args = map { ref $_ ? @$_ : $_ } @args;

  @args = map { quotemeta } @args
    unless $^O eq 'MSWin32';

  my $exec = join(' ',
      # the external app to run
      ($self->{git_backticks} ||= 'git'),
      $command,
      @args
  );

  return (`$exec`);
}

sub git_repository {
  my ($self, $command, @args) = @_;
  # Git::Repository 1.22 fails with alternate $/ (rt-71621)
  local $/ = "\n";
  (
    $self->{git_repository} ||=
    do {
      require Git::Repository;
      Git::Repository->new(work_tree => $self->{directory})
    }
  )
    ->run($command,
      map { ref $_ ? @$_ : $_ } @args
    );
}

sub git_wrapper {
  my ($self, $command, @args) = @_;
  $command =~ tr/-/_/;
  (
    $self->{git_wrapper} ||=
    do {
      require Git::Wrapper;
      Git::Wrapper->new($self->{directory})
    }
  )
    ->$command({
      map { ($$_[0] =~ /^-{0,2}(.+)$/, $$_[1]) }
        map { ref $_ ? $_ : [$_ => 1] } @args
    });
}



sub parse_version {
  my ($self, $prefix, $count) = @_;

  # This is unlikely as it should mean that both git commands
  # returned unexpected output.  If it does happen, don't die
  # trying to parse it, default to first_version.
  $prefix = $self->{first_version}
    unless defined $prefix;
  $count ||= 0;

  # If still undef (first_version explicitly set to undef)
  # don't die trying to parse it, just return nothing.
  unless( defined $prefix ){
    warn("Version could not be determined.\n");
    return;
  }

  # s//$1/ requires the regexp to be anchored.
  # Doing a match and then assigning to $1 does not.
  if( $self->{version_regexp} && $prefix =~ /$self->{version_regexp}/ ){
    $prefix = $1;
  }

  my $vstring = "v$prefix.$count";

  # quote 'version' to reference the module and not call the local sub
  my $vobject = eval {
    # don't even try to parse it if it doesn't look like a version
    'version'->parse($vstring)
      if version::is_lax($vstring);
  };

  # Don't die if it's not parseable, just return nothing.
  if( my $error = $@ || !$vobject ){
    $error = $self->prepare_warning($error);
    warn("'$vstring' is not a valid version string.\n$error");
    return;
  }

  return $self->format_version($vobject);
}

# normalize error message

sub prepare_warning {
  my ($self, $error) = @_;
  return '' unless $error;
  $error =~ s/ at \S+?\.pm line \d+\.?\s*$//;
  chomp($error);
  return $error . "\n";
}


sub version {
  my ($self) = @_;
  return $self->version_from_describe() ||
    $self->version_from_count_objects();
}


sub version_from_describe {
  my ($self) = @_;
  my ($ver) = eval {
    $self->git('describe',
      ['--match' => $self->{match_pattern}], qw(--tags --long)
    );
  };
  # usually you'll expect a tag to be found, so warn if it isn't
  if( my $error = $@ ){
    $error = $self->prepare_warning($error);
    warn("git-describe: $error");
  }

  # return nothing so we know to move on to count-objects
  return unless $ver;

  # ignore the -gSHA
  my ($tag, $count) = ($ver =~ /^(.+?)-(\d+)-(g[0-9a-f]+)$/);

  return $self->parse_version($tag, $count);
}


sub version_from_count_objects {
  my ($self) = @_;
  my @counts = $self->git(qw(count-objects -v));
  my $count = 0;
  local $_;
  foreach (@counts){
    /(count|in-pack): (\d+)/ and $count += $2;
  }
  return $self->parse_version($self->{first_version}, $count);
}

1;


__END__