File Coverage

lib/Parse/Distname.pm

Criterion	Covered	Total	%
statement	109	113	96.4
branch	47	54	87.0
condition	31	40	77.5
subroutine	19	19	100.0
pod	4	14	28.5
total	210	240	87.5

package Parse::Distname;

use strict;
use warnings;
use Carp;
use Exporter 5.57 'import';

our $VERSION = '0.04';
our @EXPORT_OK = qw/parse_distname/;

our $SUFFRE = qr/\.(?:tgz|tbz|tar[\._-]gz|tar\.bz2|tar\.Z|zip)$/;

sub parse_distname {
  my $distname = shift;

  my %res;

  # Stringify first, in case $distname is some kind of an object
  my $path = "$distname";
  $res{arg} = $path;

  # Small path normalization
  $path =~ s!\\!/!g;
  $path =~ s!//+!/!g;
  $path =~ s!/\./!/!g;

  $path =~ s!^(.*?/)?(?:authors/)?id/!!;

  # Get pause_id
  my ($pause_id, $author_dir);

  # A/AU/AUTHOR/Dist-Version.ext
  if ($path =~ s!^(([A-Z])/(\2[A-Z0-9])/(\3[A-Z0-9-]{0,7})/)!!) {
    $author_dir = $1;
    $pause_id   = $4;
  }
  # AUTHOR/Dist-Version.ext as a handy shortcut (esp. for testing)
  elsif ($path =~ s!^([A-Z][A-Z0-9][A-Z0-9-]{0,7})/!!) {
    $pause_id = $1;
    $author_dir = join '/',
      substr($pause_id, 0, 1),
      substr($pause_id, 0, 2),
      $pause_id,
      "";
  }
  # A little backward incompatibility here (id/A/AU/AUTHOR etc)
  # but I believe nobody cares.
  else {
    $pause_id = "";

    # Assume it's a local distribution
    $author_dir = "L/LO/LOCAL/";
  }
  $res{pause_id}  = $pause_id;
  $res{cpan_path} = "$author_dir$path";

  # Now the path should be (subdir/)dist-version
  if ($path =~ s!^(.+/)!!) {
    $res{subdir} = $1;

    # Typical Perl6 distributions are located under Perl6/ directory
    $res{perl6} = 1 if $res{subdir} =~ m!^Perl6/!;
  }

  # PAUSE allows only a few extensions ($PAUSE::dist::SUFFQR + zip)
  $path =~ s/($SUFFRE)//i or return;
  $res{extension} = $1;

  $res{name_and_version} = $path;

  # Parse dist-version
  my $info = _parse_distv($path);
  $res{$_} = $info->{$_} for keys %$info;

  return \%res;
}

sub _parse_distv {
  my $distv = shift;

  my %res;

  # Remove potential -withoutworldwriteables suffix
  $distv =~ s/-withoutworldwriteables$//;

  my $trial;
  # Remove TRIAL (PAUSE::dist::isa_dev_version seems to be
  # a little too strict)
  if ($distv =~ s/([_\-])(TRIAL(?:[0-9]*|[_.\-].+))$//) {
    $trial = [$1, $2];
  }

  # Remove RC for perl as well
  my $rc;
  if ($distv =~ /^perl/ and $distv =~ s/\-(RC[0-9]*)$//) {
    $rc = $1;
  }

  my $version;
  # Usually a version, which starts with a number (or a 'v'-number),
  # is the last part of the name.
  if ($distv =~ s/\-((?:[vV][0-9]|[0-9.])[^-]*)$//) {
    $version = $1;
  }
  # However, there may be a trailing part.
  elsif ($distv =~ s/\-((?:[vV][0-9]|[0-9.])(?![A-Z]).*?)$//) {
    $version = $1;

    # Special case
    if ($distv eq 'perl' and $version !~ /\./) {
      $distv = "$distv-$version";
      $version = undef;
    }
  }

  # If the name still contains a dot between numbers,
  # it's probably a part of the version.
  if ($distv =~ s/([_\.-]?)([vV]?[0-9]*\.[0-9]+.*)$//) {
    my $separator = $1 || '';
    $version = defined $version ? "$2-$version" : $2;
    $version =~ s/^\.//;

    # Special case
    if ($distv =~ s/_v$//) {
      $version = "v$separator$version";
    }
  }

  # If we still don't have a version and the name has a tailing number
  # with a small-letter prefix (other than 'v')
  if (!defined $version and $distv =~ s/\-([a-z]+[0-9][0-9_]*)$//) {
    $version = $1;
  }

  # If we still don't have a version, and the name doesn't have a hyphen,
  # and it has a tailing number... (and an occasional alpha/beta marker)
  # (and the number is not a part of a few proper names)
  if (!defined $version and $distv !~ /\-(?:S3|MSWin32|OS2|(?:[A-Za-z][A-Za-z0-9_]*)?SSL3)$/i and $distv =~ s/([_\.]?)([vV]?[0-9_]+[ab]?)$//) {
    my $separator = $1;
    $version = $2;

    # Special case
    if (!$separator and $distv =~ s/_([a-z])$//) {
      $version = "$1$version";
    }
  }

  # Special case that should be put at the end
  if (!defined $version and $distv =~ s/\-undef$//) {
    $version = undef;
  }

  my $dist = $distv;

  my $dev;
  if ($dist eq 'perl') {
    if ($version =~ /\d\.(\d+)(?:\D(\d+))?/) {
      $dev = 1 if ($1 > 6 and $1 & 1) or ($2 and $2 >= 50);
    }
    if ($rc) {
      $version = "$version-$rc";
      $dev = 1;
    }
  }
  elsif (($version and $version =~ /\d\.\d+_\d/) or $trial) {
    $dev = 1;
  }

  if ($trial) {
    $version = defined $version ? "$version$trial->[0]$trial->[1]" : $trial->[1];
    $dev = 1;
  }

  # Normalize the Dist.pm-1.23 convention which CGI.pm and
  # a few others use.
  $dist =~ s/\.pm$//;

  # Remove apparent remnants that can't be a part of a package name
  $dist =~ s/[\-\.]+$//;

  my $version_number;
  if (defined $version) {
    if ($version =~ /^([vV]?[0-9._]+)(?:\-|$)/) {
      $version_number = $1;
      $version_number =~ s/[\._]+$//;
    }
  }

  return {
    name => $dist,
    version => $version,
    version_number => $version_number,
    is_dev => $dev,
  };
}

# for compatibility with CPAN::DistnameInfo

sub new {
  my ($class, $distname) = @_;
  my $info = parse_distname($distname) || {};
  bless $info, $class;
}

sub distname_info {
  my $distname = shift;
  my $info = parse_distname($distname);
  @$info{qw/name version is_dev/};
}

sub dist      { shift->{name} }
sub version   { shift->{version} }
sub maturity  { shift->{is_dev} ? 'developer' : 'released' }
sub filename  {
  my $self = shift;
  join "", grep defined $_, @$self{qw/subdir name_and_version extension/};
}
sub cpanid    { shift->{pause_id} }
sub distvname { shift->{name_and_version} }
sub extension { substr(shift->{extension}, 1) }
sub pathname  { shift->{arg} }

sub properties {
  my $self = shift;
  my @methods = qw/
    dist version maturity filename
    cpanid distvname extension pathname
  /;
  my %properties;
  for my $method (@methods) {
    $properties{$method} = $self->$method;
  }
  %properties;
}

# extra accessors

sub is_perl6       { shift->{is_perl6} }
sub version_number { shift->{version_number} }

1;

__END__