File Coverage

blib/lib/Dist/Metadata/Dist.pm

Criterion	Covered	Total	%
statement	130	140	92.8
branch	44	54	81.4
condition	15	20	75.0
subroutine	29	35	82.8
pod	23	23	100.0
total	241	272	88.6

#
# This file is part of Dist-Metadata
#
# This software is copyright (c) 2011 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 Dist::Metadata::Dist;
our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Base class for format-specific implementations
$Dist::Metadata::Dist::VERSION = '0.927';
use Carp qw(croak carp);     # core
use CPAN::DistnameInfo 0.12 ();
use Path::Class 0.24 ();
use Try::Tiny 0.09;


sub new {
  my $class = shift;
  my $self  = {
    @_ == 1 ? %{ $_[0] } : @_
  };

  bless $self, $class;

  my $req = $class->required_attribute;
  croak qq['$req' parameter required]
    if $req && !$self->{$req};

  if ( exists $self->{file_spec} ) {
    # we just want the OS name ('Unix' or '')
    $self->{file_spec} =~ s/^File::Spec(::)?//
      if $self->{file_spec};
    # blank is no good, use "Native" hack
    $self->{file_spec} = 'Native'
      if !$self->{file_spec};
  }

  return $self;
}


sub default_file_spec { 'Native' }


sub determine_name_and_version {
  my ($self) = @_;
  $self->set_name_and_version( $self->parse_name_and_version( $self->root ) );
  return;
}


sub determine_packages {
  my ($self, @files) = @_;

  my $determined = try {
    my @dir_and_files = $self->physical_directory(@files);

    # return
    $self->packages_from_directory(@dir_and_files);
  }
  catch {
    carp("Error determining packages: $_[0]");
    +{}; # return
  };

  return $determined;
}


sub extract_into {
  my ($self, $dir, @files) = @_;

  @files = $self->list_files
    unless @files;

  require File::Basename;

  my @disk_files;
  foreach my $file (@files) {
    my $ff = $self->path_class_file->new_foreign( $self->file_spec, $file );
    # Translate dist format (relative path) to disk/OS format and prepend $dir.
    # This dir_list + basename hack is probably ok because the paths in a dist
    # should always be relative (if there *was* a volume we wouldn't want it).
    my $path = $self->path_class_file
      ->new( $dir, $ff->dir->dir_list, $ff->basename );

    $path->dir->mkpath(0, oct(700));

    my $full_path = $path->stringify;
    open(my $fh, '>', $full_path)
      or croak "Failed to open '$full_path' for writing: $!";
    print $fh $self->file_content($file);

    # do we really want full path or do we want relative?
    push(@disk_files, $full_path);
  }

  return (wantarray ? ($dir, @disk_files) : $dir);
}


sub file_content {
  croak q[Method 'file_content' not defined];
}


sub file_checksum {
  my ($self, $file, $type) = @_;
  $type ||= 'md5';

  require Digest; # core

  # md5 => MD5, sha256 => SHA-256
  (my $impl = uc $type) =~ s/^(SHA|CRC)([0-9]+)$/$1-$2/;

  my $digest = Digest->new($impl);

  $digest->add( $self->file_content($file) );
  return $digest->hexdigest;
}


sub find_files {
  croak q[Method 'find_files' not defined];
}


sub file_spec {
  my ($self) = @_;

  $self->{file_spec} = $self->default_file_spec
    if !exists $self->{file_spec};

  return $self->{file_spec};
}


sub full_path {
  my ($self, $file) = @_;

  return $file
    unless my $root = $self->root;

  # don't re-add the root if it's already there
  return $file
    # FIXME: this regexp is probably not cross-platform...
    # FIXME: is there a way to do this with File::Spec?
    if $file =~ m@^\Q${root}\E[\\/]@;

  # FIXME: does this foreign_file work w/ Dir ?
  return $self->path_class_file
    ->new_foreign($self->file_spec, $root, $file)->stringify;
}


sub list_files {
  my ($self) = @_;

  $self->{_list_files} = do {
    my @files = sort $self->find_files;
    my ($root, @rel) = $self->remove_root_dir(@files);
    $self->{root} = $root;
    \@rel; # return
  }
    unless $self->{_list_files};

  return @{ $self->{_list_files} };
}


{
  no strict 'refs'; ## no critic (NoStrict)
  foreach my $method ( qw(
    name
    version
  ) ){
    *$method = sub {
      my ($self) = @_;

      $self->determine_name_and_version
        if !exists $self->{ $method };

      return $self->{ $method };
    };
  }
}


sub packages_from_directory {
  my ($self, $dir, @files) = @_;

  my @pvfd = ($dir);
  # M::M::p_v_f_d expects full paths for \@files
  push @pvfd, [map {
    $self->path_class_file->new($_)->is_absolute
      ? $_ : $self->path_class_file->new($dir, $_)->stringify
  } @files]
    if @files;

  require Module::Metadata;

  my $provides = try {
    my $packages = Module::Metadata->package_versions_from_directory(@pvfd);
    while ( my ($pack, $pv) = each %$packages ) {
      # M::M::p_v_f_d returns files in native OS format (obviously);
      # CPAN::Meta expects file paths in Unix format
      $pv->{file} = $self->path_class_file
        ->new($pv->{file})->as_foreign('Unix')->stringify;
    }
    $packages; # return
  }
  catch {
    carp("Failed to determine packages: $_[0]");
    +{}; # return
  };
  return $provides || {};
}


sub parse_name_and_version {
  my ($self, $path) = @_;
  my ( $name, $version );
  if ( $path ){
    # try a simple regexp first
    $path =~ m!
      ([^\\/]+)             # name (anything below final directory)
      -                     # separator
      (v?[0-9._]+)          # version
      (?:                   # possible file extensions
          \.t(?:ar\.)?gz
      )?
      $
    !x and
      ( $name, $version ) = ( $1, $2 );

    # attempt to improve data with CPAN::DistnameInfo (but ignore any errors)
    # TODO: also grab maturity and cpanid ?
    # release_status = $dist->maturity eq 'released' ? 'stable' : 'unstable';
    # -(TRIAL|RC) => 'testing', '_' => 'unstable'
    eval {
      # DistnameInfo expects any directories in unix format (thanks jeroenl)
      my $dnifile = $self->path_class_file
        ->new($path)->as_foreign('Unix')->stringify;
      # if it doesn't appear to have an extension fake one to help DistnameInfo
      $dnifile .= '.tar.gz' unless $dnifile =~ /\.[a-z]\w+$/;

      my $dni  = CPAN::DistnameInfo->new($dnifile);
      my $dni_name    = $dni->dist;
      my $dni_version = $dni->version;
      # if dni matched both name and version, or previous regexp didn't match
      if ( $dni_name && $dni_version || !$name ) {
        $name    = $dni_name    if $dni_name;
        $version = $dni_version if $dni_version;
      }
    };
    warn $@ if $@;
  }
  return ($name, $version);
}


sub path_class_dir  { $_[0]->{path_class_dir}  ||= 'Path::Class::Dir'  }
sub path_class_file { $_[0]->{path_class_file} ||= 'Path::Class::File' }


sub path_classify_dir  {
  my ($self, $dir) = @_;
  $self->path_class_dir->new_foreign($self->file_spec, $dir)
}

sub path_classify_file {
  my ($self, $file) = @_;
  $self->path_class_file->new_foreign($self->file_spec, $file)
}


sub perl_files {
  return
    grep { /\.pm$/ }
    $_[0]->list_files;
}


sub physical_directory {
  my ($self, @files) = @_;

  require   File::Temp;
  # dir will be removed when return value goes out of scope (in caller)
  my $dir = File::Temp->newdir();

  return $self->extract_into($dir, @files);
}


sub remove_root_dir {
  my ($self, @files) = @_;
  return unless @files;

  # FIXME: can we use File::Spec for these regexp's instead of [\\/] ?

  # grab the root dir from the first file
  $files[0] =~ m{^([^\\/]+)[\\/]}
    # if not matched quit now
    or return (undef, @files);

  my $dir = $1;
  my @rel;

  # strip $dir from each file
  for (@files) {

    m{^\Q$dir\E[\\/](.+)$}
      # if the match failed they're not all under the same root so just return now
      or return (undef, @files);

    push @rel, $1;
  }

  return ($dir, @rel);

}


sub required_attribute { return }


sub root {
  my ($self) = @_;

  # call list_files instead of find_files so that it caches the result
  $self->list_files
    unless exists $self->{root};

  return $self->{root};
}


sub set_name_and_version {
  my ($self, @values) = @_;
  my @fields = qw( name version );

  foreach my $i ( 0 .. $#fields ){
    $self->{ $fields[$i] } = $values[$i]
      if !exists $self->{ $fields[$i] } && defined $values[$i];
  }
  return;
}


# version() defined with name()

1;

__END__