update tarball.pm

metacpan · Jan 20, 2015 · 5436277 · 5436277
1 parent 71dbd47
commit 5436277
Show file tree

Hide file tree

Showing 4 changed files with 75 additions and 69 deletions.
diff --git a/cpanfile b/cpanfile
@@ -95,6 +95,7 @@ requires 'MooseX::ClassAttribute';
 requires 'MooseX::Getopt';
 requires 'MooseX::Getopt::Dashes';
 requires 'MooseX::Getopt::OptionTypeMap';
+requires 'MooseX::StrictConstructor';
 requires 'MooseX::Types';
 requires 'MooseX::Types::Common::String';
 requires 'MooseX::Types::ElasticSearch', ' == 0.0.2'; # Newer versions use the other ES module which we can't upgrade to yet b/c of ESX-Model.

diff --git a/lib/MetaCPAN/Model/Tarball.pm b/lib/MetaCPAN/Model/Tarball.pm
@@ -22,106 +22,97 @@ has files => (
     isa      => ArrayRef,
     init_arg => undef,
     lazy     => 1,
-    builder  => '_build_files'
-);
-
-has base_dir => (
-    is      => 'ro',
-    isa     => Dir,
-    coerce  => 1,
-    default => '/tmp',
+    builder  => '_build_files',
 );
 
 has date => (
-    is  => 'ro',
+    is  => 'rw',
     isa => 'DateTime',
 );
 
-has index => (
-    is         => 'ro',
-    lazy_build => 1,
-);
+has index => ( is => 'rw', );
 
 has author => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'Str',
 );
 
 has name => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'Str',
 );
 
-has metadata => (
-    is         => 'ro',
-    lazy_build => 1,
-);
+has metadata => ( is => 'rw', );
 
 has status => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'HashRef',
 );
 
 has distribution => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'Str',
 );
 
 has version => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'Str',
 );
 
 has maturity => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'Str',
 );
 
 has release => (
-    is         => 'ro',
-    lazy_build => 1,
+    is  => 'rw',
+    isa => 'HashRef',
 );
 
+has tmpdir => (
+    is  => 'rw',
+    isa => Dir,
+);
+
+has bulk => ( is => 'rw', );
+
 sub _build_files {
     my $self = shift;
-    log_info {"Processing $self->tarball"};
+    log_info {'Processing ', $self->tarball};
 
-    my $at = Archive::Any->new( $self->tarball );
-    my $tmpdir
-        = dir( File::Temp::tempdir( CLEANUP => 0, DIR => $self->base_dir ) );
-    log_error {"$self is being impolite"} if $at->is_impolite;
+    my $archive = Archive::Any->new( $self->tarball );
 
-    log_error {"$self is being naughty"} if $at->is_naughty;
+    log_error {"$self->tarball is being impolite"} if $archive->is_impolite;
 
-    log_debug {"Extracting archive to filesystem"};
-    $at->extract($tmpdir);
+    log_error {"$self->tarball is being naughty"} if $archive->is_naughty;
+
+    log_debug {'Extracting archive to filesystem'};
+    $archive->extract( $self->tmpdir );
 
     my @files;
-    my @list = $at->files;
-    log_debug { 'Indexing ', scalar @list, " files" };
+    log_debug { 'Indexing ', scalar $archive->files, 'files' };
     my $file_set = $self->index->type('file');
-    my $bulk = $self->index->bulk( size => 10 );
 
     File::Find::find(
         sub {
             my $child
                 = -d $File::Find::name
                 ? dir($File::Find::name)
                 : file($File::Find::name);
-            my $relative = $child->relative($tmpdir);
+            my $relative = $child->relative( $self->tmpdir );
             my $stat     = do {
                 my $s = $child->stat;
                 +{ map { $_ => $s->$_ } qw(mode uid gid size mtime) };
             };
-            return if is_broken_symlink($File::Find::name);
-            return if is_broken_file($File::Find::name);
-            return if ( $relative eq '.' );
+            return if _is_broken_symlink($File::Find::name);
+            return if _is_broken_file($File::Find::name);
+            return if ( $relative eq q{.} );
             ( my $fpath = "$relative" ) =~ s/^.*?\///;
             my $fname = $fpath;
             $child->is_dir
                 ? $fname =~ s/^(.*\/)?(.+?)\/?$/$2/
                 : $fname =~ s/.*\///;
-            $fpath = "" if $relative !~ /\// && !$at->is_impolite;
+            $fpath = q{} if $relative !~ /\// && !$archive->is_impolite;
 
             my $file = $file_set->new_document(
                 Dlog_trace {"adding file $_"} +{
@@ -148,17 +139,17 @@ sub _build_files {
                     content_cb => sub { \( scalar $child->slurp ) },
                 }
             );
-            $bulk->put($file);
+            $self->bulk->put($file);
             push( @files, $file );
         },
-        $tmpdir
+        $self->tmpdir
     );
-    $bulk->commit;
+    $self->bulk->commit;
 
     return \@files;
 }
 
-sub is_broken_symlink {
+sub _is_broken_symlink {
     my $self = shift;
     if ( -l $self ) {
         my $syml = readlink $self;
@@ -167,10 +158,9 @@ sub is_broken_symlink {
     return 0;
 }
 
-sub is_broken_file {
+sub _is_broken_file {
     my $self = shift;
-    return 1 if ( -p $self || !-e $self );
-    return 0;
+    return ( -p $self || !-e $self );
 }
 
 __PACKAGE__->meta->make_immutable();

diff --git a/lib/MetaCPAN/Script/Release.pm b/lib/MetaCPAN/Script/Release.pm
@@ -18,6 +18,7 @@ use LWP::UserAgent;
 use Log::Contextual qw( :log :dlog );
 use MetaCPAN::Document::Author;
 use MetaCPAN::Script::Latest;
+use MetaCPAN::Model::Tarball;
 use MetaCPAN::Types qw( Dir );
 use Module::Metadata 1.000012 ();    # Improved package detection.
 use Moose;
@@ -201,34 +202,30 @@ sub run {
 }
 
 sub import_tarball {
-    my ( $self, $tarball ) = @_;
-
-    $tarball = MetaCPAN::Model::Tarball->new( tarball => $tarball );
+    my ( $self, $tar ) = @_;
     my $cpan = $self->index;
 
-    my $d = CPAN::DistnameInfo->new($tarball);
+    $tar = Path::Class::File->new($tar);
+    my $d = CPAN::DistnameInfo->new($tar);
     my ( $author, $archive, $name )
         = ( $d->cpanid, $d->filename, $d->distvname );
-    $tarball->author = $author;
-    $tarball->name   = $name;
-
-    $tarball->date = DateTime->from_epoch( epoch => $tarball->stat->mtime );
+    my $tmpdir
+        = dir( File::Temp::tempdir( CLEANUP => 0, DIR => $self->base_dir ) );
+    my $date    = DateTime->from_epoch( epoch => $tar->stat->mtime );
     my $version = MetaCPAN::Util::fix_version( $d->version );
     my $meta    = CPAN::Meta->new(
         {
             version => $version || 0,
             license => 'unknown',
             name    => $d->dist,
-            no_index =>
-                { directory => [qw(t xt inc example blib examples eg)] }
+            no_index => { directory => [@always_no_index_dirs] },
         }
     );
 
-    my $st = $tarball->stat;
+    my $st = $tar->stat;
     my $stat = { map { $_ => $st->$_ } qw(mode uid gid size mtime) };
 
     $meta = $self->load_meta_file($tmpdir) || $meta;
-    $tarball->meta = $meta;
 
     log_debug {'Gathering dependencies'};
 
@@ -270,8 +267,24 @@ sub import_tarball {
             ->put( { name => $d->dist }, { create => 1 } );
     };
 
-    $tarball->index = $cpan;
-    my @files = $tarball->files;
+    my $bulk = $cpan->bulk( size => 10 );
+
+    my $tarball = MetaCPAN::Model::Tarball->new(
+        tarball      => $tar,
+        author       => $author,
+        name         => $name,
+        date         => $date,
+        metadata     => $meta,
+        index        => $cpan,
+        status       => $stat,
+        distribution => $d->dist,
+        version      => $d->version,
+        maturity     => $d->maturity,
+        bulk         => $bulk,
+    );
+
+    my @files;
+    $tarball->files(@files);
 
     log_debug {'Gathering modules'};
 
@@ -404,7 +417,7 @@ sub import_tarball {
         }
     }
     if (@provides) {
-        $release->provides( \@provides );
+        $release->provides( [ sort @provides ] );
         $release->put;
     }
     $bulk->commit;

diff --git a/t/model/tarball.t b/t/model/tarball.t
@@ -1,4 +1,6 @@
 use Test::Most;
+use strict;
+use warnings;
 
 use MetaCPAN::Model::Tarball;