File Coverage

blib/lib/CPAN/InGit.pm

Criterion	Covered	Total	%
statement	108	236	45.7
branch	22	108	20.3
condition	4	29	13.7
subroutine	19	25	76.0
pod	8	9	88.8
total	161	407	39.5

package CPAN::InGit;

our $VERSION = '0.003'; # VERSION
# ABSTRACT: Manage custom CPAN trees to pin versions for your projects

use Git::Raw::Repository;
use Archive::Tar;
use Archive::Tar::Constant; # for constants to be avilable at compile time
use Scalar::Util 'blessed';
use CPAN::InGit::MirrorTree;
use CPAN::Meta 2.150010;
use Module::Metadata;
use Fcntl qw( S_ISREG S_ISLNK S_IFMT S_ISDIR );
use Carp;
use Moo;
use v5.36;


sub BUILDARGS($class, @list) {
   unshift @list, 'git_repo' if @list == 1;
   my $args= $class->next::method(@list);
   $args->{git_repo}= delete $args->{repo} if defined $args->{repo};
   $args;
}

has git_repo                  => ( is => 'ro', required => 1, coerce => \&_open_repo );
has git_author_name           => ( is => 'rw', default => 'CPAN::InGit' );
has git_author_email          => ( is => 'rw', default => 'CPAN::InGit@localhost' );

has workdir_branch_name       => ( is => 'lazy' );
sub _build_workdir_branch_name($self) {
   return undef if $self->git_repo->is_bare || $self->git_repo->is_head_detached;
   return $self->git_repo->head->shorthand;
}

has useragent                 => ( is => 'lazy' );
sub _build_useragent($self) {
   require Mojo::UserAgent;
   return Mojo::UserAgent->new;
}

sub _open_repo($thing) {
   return $thing if blessed($thing) && $thing->isa('Git::Raw::Repository');
   return Git::Raw::Repository->open("$thing");
}


sub get_archive_tree($self, $branch_or_tag_or_id) {
   my ($tree, $origin)= $self->lookup_tree($branch_or_tag_or_id);
   return undef unless $tree;

   my $branch= $origin && ref($origin)->isa('Git::Raw::Branch')? $origin : undef;

   # If HEAD requested or using the branch pointed to by HEAD, and if it has a work directory,
   # then apply any changes to the workdir.
   my $use_workdir= !$self->git_repo->is_bare && (($branch && $branch->is_head) || $branch_or_tag_or_id eq 'HEAD');

   # Does it look like an ArchiveTree?
   my $config_blob;
   if ($use_workdir) {
      my $ent= $self->git_repo->index->find('cpan_ingit.json');
      return undef unless $ent;
      $config_blob= $ent->blob;
   } else {
      my $ent= $tree->entry_bypath('cpan_ingit.json');
      return undef unless $ent;
      $config_blob= $ent->object;
   }
   my $cfg= JSON::PP->new->relaxed->decode($config_blob->content);
   my $class= $cfg->{upstream_url}? 'CPAN::InGit::MirrorTree' : 'CPAN::InGit::ArchiveTree';
   return $class->new(
      parent => $self,
      tree => $tree,
      use_workdir => $use_workdir,
      (branch => $branch)x!!$branch,
   );
}


sub create_archive_tree($self, $name, %params) {
   croak "Branch '$name' already exists"
      if Git::Raw::Branch->lookup($self->git_repo, $name, 1);
   croak "Branch '$name' already exists upstream"
      if Git::Raw::Branch->lookup($self->git_repo, $name, 0);
   my $t;
   if ($params{upstream_url}) {
      $t= CPAN::InGit::MirrorTree->new(%params, parent => $self);
      $t->add_upstream_package_details;
   } else {
      $t= CPAN::InGit::ArchiveTree->new(%params, parent => $self);
      $t->write_package_details;
   }
   # It won't exist until we create a commit and create a branch.
   $t->write_config;
   $t->commit("Called create_archive_tree", create_branch => $name);
   return $t;
}


sub lookup_tree($self, $branch_or_tag_or_id) {
   my ($tree, $origin);
   defined $branch_or_tag_or_id or croak "missing argument";
   my $repo= $self->git_repo;
   if (blessed($branch_or_tag_or_id) && (
         $branch_or_tag_or_id->isa('Git::Raw::Branch')
      || $branch_or_tag_or_id->isa('Git::Raw::Tag')
   )) {
      $origin= $branch_or_tag_or_id;
      $tree= $origin->peel('tree');
   } elsif ($branch_or_tag_or_id eq 'HEAD') {
      $tree= $repo->head->target->peel('tree');
      $origin= $repo->is_head_detached? undef
             : $repo->head;
   } elsif ($origin= eval { Git::Raw::Branch->lookup($repo, $branch_or_tag_or_id, 1) }) {
      $tree= $origin->peel('tree');
   } elsif ($origin= eval { Git::Raw::Tag->lookup($repo, $branch_or_tag_or_id) }) {
      $tree= $origin->peel('tree');
   } elsif (my $obj= eval { $repo->lookup($branch_or_tag_or_id) }) {
      if ($obj->type == Git::Raw::Object::COMMIT()) {
         $origin= Git::Raw::Commit->lookup($repo, $obj->id);
         $tree= $origin->tree;
      } elsif ($obj->type == Git::Raw::Object::TREE()) {
         $tree= Git::Raw::Tree->lookup($repo, $obj->id);
      } elsif ($obj->type == Git::Raw::Object::TAG()) {
         $origin= Git::Raw::Tag->lookup($repo, $obj->id);
         $tree= $origin->target;
      }
   }
   return wantarray? ($tree, $origin) : $tree;
}


sub add_git_tree_to_tar($self, $tar, $path, $tree) {
   unless ($tree->can('entries')) {
      my $id= $tree;
      $tree = Git::Raw::Tree->lookup($self->git_repo, $id)
         or die "Can't find TREE $id referenced by '$path'";
   }
   $self->add_git_dirent_to_tar($tar, "$path/".$_->name, $_)
      for $tree->entries;
}

sub add_git_dirent_to_tar($self, $tar, $path, $dirent) {
   if ($dirent->type == Git::Raw::Object::BLOB()) {
      my $mode = $dirent->file_mode;
      my $blob = Git::Raw::Blob->lookup($self->git_repo, $dirent->id)
         or die "Can't find BLOB ".$dirent->id." referenced by '$path'";
      # Check if it's a symlink (mode 0120000 or 40960 decimal)
      if (($mode & 0170000) == 0120000) {
         # Symlink: content is the target path
         $tar->add_data($path, $blob->content, {
            mode => $mode,
            type => Archive::Tar::Constant::SYMLINK,
            linkname => $blob->content
         });
      }
      else {
         # Regular file
         $tar->add_data($path, $blob->content, { mode => $mode });
      }
   }
   elsif ($dirent->type == Git::Raw::Object::TREE()) {
      $self->add_git_tree_to_tar($tar, $path, $dirent->id);
   }
   else {
      warn "Omitting $path from TAR, not a BLOB or TREE";
   }
}


sub new_signature($self) {
   Git::Raw::Signature->now($self->git_author_name, $self->git_author_email);
}


sub lookup_versions($self, $module_name) {
   for my $up ($self->upstream_mirrors->@*) {
      ...;
   }
}


sub process_distfile($self, %opts) {
   my ($tree, $file_path, $file_data, $extract)= @opts{'tree','file_path','file_data','extract'};
   # Decompress tar in memory.  The decompression gets complicated since it can be bz2 or gz
   # so write to a temp file and then parse that with the auto-detection of "compress".
   if ($file_path =~ /\.(tar\.gz|tar\.bz2|tgz)\z/) {
      my $path_without_extension= substr($file_path, 0, $-[0]);
      my $tmp= File::Temp->new;
      $tmp->print($$file_data) or die "write: $!";
      $tmp->flush;

      # Iterate across the files in the tar archive
      my $tar= Archive::Tar->new("$tmp", 1);
      my @files= $tar->get_files;
      if (!@files) {
         croak "Failed to extract any files from archive $file_path";
      }
      # Remove prefix directory if every file in archive starts with the same directory
      (my $prefix= $files[0]->name) =~ s,/.*,,;
      $prefix .= '/';
      for (@files) {
         if (substr($_->name,0,length $prefix) ne $prefix) {
            $prefix= '';
            last;
         }
      }
      # Build by-name hash of files
      my %files= map +( substr($_->name, length $prefix) => $_ ), @files;
      my $meta;
      # Look for a META.json
      if (my $meta_json= $files{'META.json'}) {
         eval {
            my $cm= CPAN::Meta->load_json_string($meta_json->get_content);
            $meta= $cm->as_struct({ version => 2 });
         } or warn "Failed to load $file_path/${prefix}META.json: $@";
      }
      # else look for META.yml
      if (!$meta && (my $meta_yml= $files{'META.yml'})) {
         eval {
            my $cm= CPAN::Meta->load_yaml_string($meta_yml->get_content);
            $meta= $cm->as_struct({ version => 2 });
         } or warn "Failed to load $file_path/${prefix}META.yml: $@";
      }
      # TODO: add some fall-back that guesses at prereqs.
      $meta //= {};
      # If the meta didn't contain "provides", add that using Module::Metadata
      if (!$meta->{provides}) {
         my $provides= $meta->{provides}= {};
         for my $pm_fname (grep /\.pm\z/ && !m{^(t|xt|inc|script|bin)/}, keys %files) {
            eval {
               open my $pm_fh, '<', $files{$pm_fname}->get_content_by_ref or die;
               my $mm= Module::Metadata->new_from_handle($pm_fh, $pm_fname);
               for my $pkg (grep $_ ne 'main', $mm->name, $mm->packages_inside) {
                  $provides->{$pkg}{file}= $pm_fname;
                  $provides->{$pkg}{version} //= $mm->version($pkg);
               }
               1;
            } or warn "Failed to parse packages in $file_path/${prefix}$pm_fname: $@";
         }
      }
      # If caller requests 'extract', add the tar's files and symlinks to the tree
      if ($extract) {
         for (keys %files) {
            my $mode= $files{$_}->mode;
            if (S_ISREG($mode)) {
               # normalize to 644 or 755
               $mode= S_IFMT($mode) | (($mode & 1)? 0755 : 0644);
               $tree->set_path("$path_without_extension/$_", $files{$_}->get_content_by_ref, $mode);
            } elsif (S_ISLNK($mode)) {
               $tree->set_path("$path_without_extension/$_", \$files{$_}->linkname, S_IFMT($mode));
            } elsif (!S_ISDIR($mode)) {
               warn "Skipping tar entry for '$path_without_extension/$_' (mode=$mode)\n";
            }
         }
      } else {
         $tree->set_path($file_path, $file_data);
      }
      # Now serialzie the meta and write it to the tree alongside the TAR
      my $json= CPAN::Meta->new($meta)->as_string({ version => 2 });
      $tree->set_path($path_without_extension . '.json', \$json);
   }
   else {
      warn "$file_path does not appear to be a TAR file.  Skipping metadata processing.";
      $tree->set_path($file_path, $file_data);
   }
}

#=method parse_cpanfile_snapshot
#
#  $distribution_spec= $cpan_repo->parse_cpanfile_snapshot($file_contents);
#
#Given a scalar with the content of a cpanfile.snapshot from L, this returns the data of
#that file as a hierarchial structure:
#
#  {
#    "Distribution-Name-1.002003" => {
#      "pathname" => "A/AU/AUTHOR/Distribution-Name-1.002003.tar.gz",
#      "provides" => {
#        "Distribution::Name" => '1.002003',
#        ...
#      },
#      "requirements" => {
#        "Dependency" => "2.05",
#        ...
#      }
#    }
#  }
#
#=cut

sub _context {
   my $context= substr($_, pos($_), $_[0]);
   $context =~ s/\r/\\r/g;
   $context =~ s/\n/\\n/g;
   return $context;
}
sub _parse_cpanfile_snapshot($self, $text) {
   # TODO: use official module if available, else fall back to this:
   my %distributions;
   local $_= $text;
   unless (eval {
      /^# carton snapshot format: version 1.0\r?\n/mgc
         or die "Unsupported cpanfile.snapshot version\n";
      /\GDISTRIBUTIONS\r?\n/gc
         or die "expected DISTRIBUTIONS\n";
      while (length > pos) {
         my ($dist_name)= /\G  (\S+)\r?\n/gc
            or die "expected dist name\n";
         my $dist= $distributions{$dist_name}= {};
         while (/\G    (\w[^\r\n:]*): *(.*?)\r?\n/gc) {
            my ($attr, $val)= ($1, $2);
            if (length $val) {
               $dist->{$attr}= $val;
            } else {
               while (/\G      (.*)\r?\n/gc) {
                  push @{ $dist->{$attr} }, $1;
               }
            }
            die "Unexpected sub-element of $dist_name $attr\n"
               if /\G      /gc;
         }
         die "Unexpected sub-element of $dist_name\n"
            if /\G    /gc;
         # convert 'provides' and 'requirements' to hashrefs of versions
         for (qw( provides requirements )) {
            if (ref $dist->{$_} eq 'ARRAY') {
               $dist->{$_}= { map +((split ' ')[0,1]), @{$dist->{$_}} };
            }
         }
      }
      1;
   }) {
      chomp $@;
      my $context= _context(20);
      croak "syntax error: $@, near \"$context\"";
   }
   \%distributions;
}


1;

__END__