File Coverage

blib/lib/App/git/ship.pm

Criterion	Covered	Total	%
statement	108	165	65.4
branch	24	80	30.0
condition	11	36	30.5
subroutine	23	32	71.8
pod	12	12	100.0
total	178	325	54.7

package App::git::ship;
use Mojo::Base -base;

use Carp;
use Data::Dumper ();
use IPC::Run3    ();
use Mojo::File 'path';
use Mojo::Loader;
use Mojo::Template;
use Mojo::Util qw(decode encode);

use constant DEBUG  => $ENV{GIT_SHIP_DEBUG}  || 0;
use constant SILENT => $ENV{GIT_SHIP_SILENT} || 0;

our $VERSION = '0.35';

# Need to be overridden in subclass
sub build { $_[0]->abort('build() is not available for %s', ref $_[0]) }
sub can_handle_project { $_[0]->abort('can_handle_project() is not available for %s', ref $_[0]) }

sub abort {
  my ($self, $format, @args) = @_;
  my $message = @args ? sprintf $format, @args : $format;

  Carp::confess("!! $message") if DEBUG;
  die "!! $message\n";
}

sub config {
  my ($self, $key, $value) = @_;
  my $config = $self->{config} ||= $self->_build_config;

  # Get all
  return $config if @_ == 1;

  # Get single key
  if (@_ == 2) {
    return $config->{$key} if exists $config->{$key};

    my $param_method = "_build_config_param_$key";
    return $self->$param_method if $self->can($param_method);

    my $env_key = uc "GIT_SHIP_$key";
    return decode 'UTF-8', $ENV{$env_key} // '';
  }

  # Set single key
  $config->{$key} = $value;
  return $self;
}

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

  if (my $class = $self->config('class')) {
    $self->abort("Could not load $class: $@") unless eval "require $class;1";
    return $class;
  }

  require Module::Find;
  for my $class (sort { length $b <=> length $a } Module::Find::findallmod(__PACKAGE__)) {
    eval "require $class;1" or next;
    next unless $class->can('can_handle_project');
    warn "[ship::detect] $class->can_handle_project($file)\n" if DEBUG;
    return $class if $class->can_handle_project($file);
  }

  $self->abort("Could not figure out what kind of project this is from '$file'");
}

sub dump {
  return Data::Dumper->new([$_[1]])->Indent(1)->Terse(1)->Sortkeys(1)->Dump;
}

sub new {
  my $self = shift->SUPER::new(@_);
  open $self->{STDOUT}, '>&STDOUT';
  open $self->{STDERR}, '>&STDERR';
  return $self;
}

sub render_template {
  my ($self, $name, $args) = @_;
  my $template = $self->_get_template($name) or $self->abort("Could not find template for $name");

  # Render to string
  return $template->process({%$args, ship => $self}) if $args->{to_string};

  # Render to file
  my $file = path split '/', $name;
  if (-e $file and !$args->{force}) {
    say "# $file exists" unless SILENT;
    return $self;
  }

  # Try to read template from $HOME/$name
  if ($args->{template_from_home}) {
    my $src = $ENV{HOME} ? path $ENV{HOME}, $name : undef $template->parse($file->slurp)
      if $file and -r $file;
  }

  $file->dirname->make_path unless -d $file->dirname;
  $file->spurt(encode 'UTF-8', $template->process({%$args, ship => $self}));
  say "# Generated $file" unless SILENT;
  return $self;
}

sub run_hook {
  my ($self, $name) = @_;
  my $cmd = $self->config($name) or return;
  $self->system($cmd);
}

sub ship {
  my $self     = shift;
  my ($branch) = qx(git branch --no-color) =~ /\* (.+)$/m;
  my ($remote) = qx(git remote -v) =~ /^origin\s+(.+)\s+\(push\)$/m;

  $self->abort("Cannot ship without a current branch") unless $branch;
  $self->abort("Cannot ship without a version number") unless $self->config('next_version');
  $self->system(qw(git push origin), $branch) if $remote;
  $self->system(qw(git tag) => $self->config('next_version'));
  $self->system(qw(git push --tags origin)) if $remote;
}

sub start {
  my $self = shift;

  if (@_ and ref($self) eq __PACKAGE__) {
    return $self->detect($_[0])->new($self)->start(@_);
  }

  $self->system(qw(git init-db)) unless -d '.git' and @_;
  $self->render_template('.gitignore');
  $self->system(qw(git add .));
  $self->system(qw(git commit -a -m), "git ship start") if @_;
  $self;
}

sub system {
  my ($self, $program, @args) = @_;
  my @fh = (undef);
  my $exit_code;

  if (SILENT) {
    my $output = '';
    push @fh, (\$output, \$output);
  }
  else {
    my $log = "$program @args";
    $log =~ s!\n\r?!\\n!g;
    say "\$ $log";
  }

  warn "[ship]\$ $program @args\n" if DEBUG == 2;
  IPC::Run3::run3(@args ? [$program => @args] : $program, @fh);
  $exit_code = $? >> 8;
  return $self unless $exit_code;

  if (SILENT) {
    chomp $fh[1];
    $self->abort("'$program @args' failed: $exit_code (${$fh[1]})");
  }
  else {
    $self->abort("'$program @args' failed: $exit_code");
  }
}

sub _build_config {
  my $self = shift;

  my $file   = $ENV{GIT_SHIP_CONFIG} || '.ship.conf';
  my $config = {};
  return $config unless open my $CFG, '<:encoding(UTF-8)', $file;

  while (<$CFG>) {
    chomp;
    warn "[ship::config] $_\n" if DEBUG == 2;
    m/\A\s*(?:\#|$)/ and next;    # comments
    s/\s+(?
    m/^\s*([^\=\s][^\=]*?)\s*=\s*(.*)$/ or next;
    my ($k, $v) = ($1, $2);
    $v =~ s!\s+$!!g;
    next unless length $v;
    $config->{$k} = $v;
    $config->{$k} =~ s!\\\#!#!g;
    warn "[ship::config] $1 = $2\n" if DEBUG;
  }

  return $config;
}

sub _build_config_param_author {
  my $self   = shift;
  my $format = shift || '%an <%ae>';

  open my $GIT, '-|', qw(git log), "--format=$format"
    or $self->abort("git log --format=$format: $!");
  my $author = decode 'UTF-8', readline $GIT;
  $self->abort("Could not find any author in git log") unless $author;
  chomp $author;
  warn "[ship::author] $format = $author\n" if DEBUG;
  return $author;
}

sub _build_config_param_bugtracker {
  return $ENV{GIT_SHIP_BUGTRACKER}
    || join('/', shift->config('homepage'), 'issues') =~ s!(\w)//!$1/!r;
}

sub _build_config_param_homepage {
  return $ENV{GIT_SHIP_HOMEPAGE} || shift->config('repository') =~ s!\.git$!!r;
}

sub _build_config_param_license      { $ENV{GIT_SHIP_LICENSE}      || 'artistic_2' }
sub _build_config_param_project_name { $ENV{GIT_SHIP_PROJECT_NAME} || 'unknown' }

sub _build_config_param_repository {
  my $self = shift;
  my $repository;

  open my $REPOSITORIES, '-|', qw(git remote -v) or $self->abort("git remote -v: $!");
  while (<$REPOSITORIES>) {
    next unless /^origin\s+(\S+).*push/;
    $repository = $1;
    last;
  }

  $repository ||= lc sprintf 'https://github.com/%s/%s',
    $self->config('username') || $ENV{GITHUB_USERNAME} || scalar(getpwuid $<),
    $self->config('project_name') =~ s!::!-!gr;
  $repository =~ s!^[^:]+:!https://github.com/! unless $repository =~ /^http/;
  warn "[ship::repository] $repository\n" if DEBUG;

  return $repository;
}

sub _get_template {
  my ($self, $name) = @_;

  my $class = ref $self;
  my $str;
  no strict 'refs';
  for my $package ($class, @{"$class\::ISA"}) {
    $str  = Mojo::Loader::data_section($package, $name) or next;
    $name = "$package/$name";
    last;
  }

  return $str ? Mojo::Template->new->name($name)->vars(1)->parse($str) : undef;
}

1;

=encoding utf8

=head1 NAME

App::git::ship - Git command for shipping your project

=head1 VERSION

0.35

=head1 SYNOPSIS

See L for how to build Perl projects.

Below is a list of useful git aliases:

  # git build
  $ git config --global alias.build 'ship build'

  # git cl
  $ git config --global alias.cl 'ship clean'

  # git start
  # git start My/Project.pm
  $ git config --global alias.start 'ship start'

=head1 DESCRIPTION

L is a L command for building and
shipping your project.

The main focus is to automate away the boring steps, but at the same time not
get in your (or any random contributor's) way. Problems should be solved with
sane defaults according to standard rules instead of enforcing more rules.

L differs from other tools like L by I
requiring any configuration except for a file containing the credentials for
uploading to CPAN.

=head2 Supported project types

Currently, only L is supported.

=head1 ENVIRONMENT VARIABLES

Environment variables can also be set in a config file named C<.ship.conf>, in
the root of the project directory. The format is:

  # some comment
  bugtracker = whatever
  new_version_format = %v %Y-%m-%dT%H:%M:%S%z

Any of the keys are the lower case version of L, but
without the "GIT_SHIP_" prefix.

Note however that all environment variables are optional, and in many cases
L will simply do the right thing, without any configuration.

=head2 GIT_SHIP_AFTER_SHIP

It is possible to add hooks. These hooks are
programs that runs in your shell. Example hooks:

  GIT_SHIP_AFTER_SHIP="bash script/new-release.sh"
  GIT_SHIP_AFTER_BUILD="rm -r lib/My/App/templates lib/My/App/public"
  GIT_SHIP_AFTER_SHIP="cat Changes | mail -s "Changes for My::App" [e-mail]"

=head2 GIT_SHIP_AFTER_BUILD

See L.

=head2 GIT_SHIP_BEFORE_BUILD

See L.

=head2 GIT_SHIP_BEFORE_SHIP

See L.

=head2 GIT_SHIP_BUGTRACKER

URL to the bugtracker for this project.

=head2 GIT_SHIP_CLASS

This class is used to build the object that runs all the actions on your
project. This is autodetected by looking at the structure and files in
your project. For now this value can be L or
L, but any customization is allowed.

=head2 GIT_SHIP_CONTRIBUTORS

Comma-separated list with C<< name  >> of the contributors to this project.

=head2 GIT_SHIP_DEBUG

Setting this variable will make "git ship" output more information.

=head2 GIT_SHIP_HOMEPAGE

URL to the home page for this project.

=head2 GIT_SHIP_LICENSE

The name of the license to use. Defaults to "artistic_2".

=head2 GIT_SHIP_SILENT

Setting this variable will make "git ship" output less information.

=head1 METHODS

These methods are interesting in case you want to extend L with
your own functionality. L does exactly this.

=head2 abort

  $ship->abort($str);
  $ship->abort($format, @args);

Will abort the application run with an error message.

=head2 build

  $ship->build;

This method builds the project. The default behavior is to L.
Needs to be overridden in the subclass.

=head2 can_handle_project

  $bool = $class->can_handle_project($file);

This method is called by L and should return boolean
true if this module can handle the given git project.

This is a class method which gets a file as input to detect or have to
auto-detect from current working directory.

All the modules in the L namespace will be loaded and asked if
they can handle the given project you are in or trying to create.

=head2 config

  $hash_ref = $ship->config;
  $str      = $ship->config($name);
  $self     = $ship->config($name => $value);

Holds the configuration from end user. The config is by default read from
C<.ship.conf> in the root of your project if such a file exists.
L can also be used to build the config, but the
settings in C<.ship.conf> has priority.

=head2 detect

  $class = $ship->detect;
  $class = $ship->detect($file);

Will detect the sub class in the L namespace which can be
used to handle a project. Will first check L or call
L on all the classes in the L
namespace if not.

=head2 dump

  $str = $ship->dump($any);

Will serialize C<$any> into a perl data structure, using L.

=head2 new

  $ship = App::git::ship->new(\%attributes);

Creates a new instance of C<$class>.

=head2 render_template

  $ship->render_template($file, \%args);

Used to render a template by the name C<$file> to a C<$file>. The template
needs to be defined in the C section of the current class or one of
the super classes.

=head2 run_hook

  $ship->run_hook($name);

Used to run a hook before or after an event. The hook is a command which needs
to be defined in L. See also L,
L, L and
L.

=head2 ship

  $ship->ship;

This method ships the project to some online repository. The default behavior
is to make a new tag and push it to "origin". Push occurs only if origin is
defined in git.

=head2 start

  $ship->start;

This method is called when initializing the project. The default behavior is
to populate L with default data:

=head2 system

  $ship->system($program, @args);

Same as perl's C, but provides error handling and logging.

=head1 SEE ALSO

=over

=item * L

This project can probably get you to the moon.

=item * L

This looks really nice for shipping your project. It has the same idea as
this distribution: Guess as much as possible.

=item * L

One magical tool for doing it all in one bang.

=back

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014-2018, Jan Henning Thorsen

This program is free software, you can redistribute it and/or modify it under
the terms of the Artistic License version 2.0.

=head1 AUTHOR

Jan Henning Thorsen - C

mohawk2 - C

Rolf Stöckli - C

Shoichi Kaji - C

=cut

__DATA__