#!/usr/bin/env perl
package App::Mypp;
use Cwd;
use File::Basename;
use File::Find;
our $VERSION = eval '0.14';
our $SILENT = $ENV{MYPP_SILENT} || $ENV{SILENT} || 0;
our $PAUSE_FILENAME = $ENV{HOME} .'/.pause';
our $VERSION_RE = qr/\d+ \. [\d_]+/x;
open my $OLDOUT, '>&STDOUT';
open my $OLDERR, '>&STDERR';
sub _from_config ($&) {
my($name, $sub) = @_;
no strict 'refs';
*$name = sub {
my $self = shift;
return $self->{$name} ||= $self->config->{$name} || $self->$sub(@_);
};
}
sub _attr ($&) {
my($name, $sub) = @_;
no strict 'refs';
*$name = sub {
my $self = shift;
return $self->{$name} ||= $self->$sub(@_);
};
}
_attr config => sub {
my $self = shift;
my $file = $ENV{MYPP_CONFIG} || 'mypp.yml';
my $config;
return {} unless(-e $file);
eval "use YAML::Tiny; 1;" or do {
die <<"ERROR";
YAML::Tiny is not installed, meaning '$file' will not be read.
Use one of the commands below to install it:
\$ aptitude install libyaml-tiny-perl
\$ wget -q http://xrl.us/cpanm -O - | perl - YAML::Tiny
ERROR
};
$config = YAML::Tiny->read($file);
return $config->[0] if($config and $config->[0]);
return {};
};
_from_config name => sub {
my $self = shift;
my $name;
$name = join '-', split '/', $self->top_module;
$name =~ s,^.?lib-,,;
$name =~ s,\.pm$,,;
return $name;
};
_from_config repository => sub {
my $repo = (qx/git remote show -n origin/ =~ /URL: (.*)$/m)[0] || 'git://github.com/';
chomp $repo;
return $repo;
};
_from_config top_module => sub {
my $self = shift;
my $name = $self->config->{name} || basename getcwd;
my @path = split /-/, $name;
my $path = 'lib';
my $file;
$path[-1] .= '.pm';
for my $p (@path) {
opendir my $DH, $path or die "Cannot find top module from project name '$name': $!\n";
for my $f (readdir $DH) {
if(lc $f eq lc $p) {
$path = "$path/$f";
last;
}
}
}
unless(-f $path) {
die "Cannot find top module from project name '$name': $path is not a plain file\n";
}
return $path;
};
_from_config top_module_name => sub {
local $_ = $_[0]->top_module;
s,\.pm,,; s,^/?lib/,,g; s,/,::,g;
return $_;
};
_attr changes => sub {
my $self = shift;
my($text, $version);
$self->_generate_file_from_template('Changes');
open my $CHANGES, '<', 'Changes' or die "Read Changes: $!\n";
while(<$CHANGES>) {
if($text) {
if(/^$/) {
last;
}
else {
$text .= $_;
}
}
elsif(/^($VERSION_RE)/) {
$version = $1;
$text = $_;
}
}
unless($text and $version) {
die "Could not find commit message nor version info from Changes\n";
}
return {
text => $text,
version => $version,
};
};
_attr dist_file => sub {
my $self = shift;
return sprintf '%s-%s.tar.gz', $self->name, $self->changes->{version};
};
_attr pause_info => sub {
open my $PAUSE, '<', $PAUSE_FILENAME or die "Read $PAUSE_FILENAME: $!\n";
my %info = map { my($k, $v) = split /\s+/, $_, 2; chomp $v; ($k, $v) } <$PAUSE>;
$info{user} or die "'user <name>' is not set in $PAUSE_FILENAME\n";
$info{password} or die "'password <mysecret>' is not set in $PAUSE_FILENAME\n";
return \%info;
};
_attr share_extension => sub {
my $self = shift;
return $ENV{MYPP_SHARE_MODULE} if($ENV{MYPP_SHARE_MODULE});
return $self->config->{share_extension} if($self->config->{share_extension});
return 'CPAN::Uploader';
};
_from_config share_params => sub {
return;
};
sub force { 0 }
my %TEMPLATES;
sub _templates {
unless(%TEMPLATES) {
my($key, $text);
while(<DATA>) {
if(/\%\% (\S+)/) {
$TEMPLATES{$key} = $text if($key);
$key = $1;
$text = '';
}
else {
$text .= $_;
}
}
$TEMPLATES{$key} = $text
}
return \%TEMPLATES;
}
sub _build {
my $self = shift;
my(@rollback, $e);
$self->_make('clean');
eval {
$self->_update_version_info;
$self->_generate_file_from_template('MANIFEST.SKIP');
$self->_system(sprintf '%s %s > %s', 'perldoc -tT', $self->top_module, 'README');
eval { $self->_system('rm ' .$self->name .'* 2>/dev/null') }; # don't care if this fail
push @rollback, sub { rename 'Changes.old', 'Changes' };
$self->_timestamp_to_changes;
push @rollback, sub { $self->_git(reset => 'HEAD^') };
$self->_git(commit => -a => -m => $self->changes->{text});
push @rollback, sub { $self->_git(tag => -d => $self->changes->{version}) };
$self->_git(tag => $self->changes->{version});
$self->_make('manifest');
$self->_make('dist');
1;
} or do {
$e = $@ || 'Not sure what went wrong';
$_->() for reverse @rollback;
die $e;
};
}
sub _timestamp_to_changes {
my $self = shift;
my $date = localtime;
my($changes, $pm);
rename 'Changes', 'Changes.old' or die $!;
open my $OLD, '<', 'Changes.old' or die "Read Changes.old: $!\n";
open my $NEW, '>', 'Changes' or die "Write Changes: $!\n";
{ local $/; $changes = <$OLD> };
if($changes =~ s/\n($VERSION_RE)\s*$/{ sprintf "\n%-7s  %s", $1, $date }/em) {
print $NEW $changes;
$self->_log("Add timestamp '$date' to Changes");
return 1;
}
die "Unable to update Changes with timestamp\n";
}
sub _update_version_info {
my $self = shift;
my $top_module = $self->top_module;
my $version = $self->changes->{version};
my $top_module_text;
open my $MODULE, '+<', $top_module or die "Read/write $top_module: $!\n";
{ local $/; $top_module_text = <$MODULE> }
seek $MODULE, 0, 0;
$top_module_text =~ s/=head1 VERSION.*?\n=/=head1 VERSION\n\n$version\n\n=/s;
$top_module_text =~ s/^((?:our)?\s*\$VERSION)\s*=.*$/$1 = eval '$version';/m;
print $MODULE $top_module_text;
$self->_log("Update version in $top_module to $version");
return 1;
}
sub _requires {
my $self = shift;
my(%requires, %test_requires, @requires, $corelist);
my $wanted = sub {
return if(!-f $_);
return if(/\.swp/);
open my $REQ, '-|', "$^X -MApp::Mypp::ShowINC '$_' 2>/dev/null";
while(<$REQ>) {
my($m, $v) = split /=/;
chomp $v;
$_[0]->{$m} = $v unless($requires{$m});
}
};
# required to skip core modules
eval "use Module::CoreList; 1" and $corelist = 1;
finddepth({ no_chdir => 1, wanted => sub { $wanted->(\%requires) } }, 'bin') if(-d 'bin');
finddepth({ no_chdir => 1, wanted => sub { $wanted->(\%requires) } }, 'lib');
finddepth({ no_chdir => 1, wanted => sub { $wanted->(\%test_requires) } }, 't');
for my $m (sort keys %requires) {
my $v = $requires{$m};
next if($self->_got_parent_module($m, \%requires));
next if($corelist and Module::CoreList->first_release($m));
push @requires, $v ? "requires q($m) => $v;" : "# requires q($m) => ??;";
}
if(%test_requires) {
push @requires, '';
}
for my $m (sort keys %test_requires) {
my $v = $test_requires{$m};
next if($self->_got_parent_module($m, \%requires));
next if($corelist and Module::CoreList->first_release($m));
push @requires, $v ? "test_requires q($m) => $v;" : "# test_requires q($m) => ??;";
}
return join "\n", @requires;
}
sub _got_parent_module {
my($self, $module, $map) = @_;
for my $m (keys %$map) {
next unless($map->{$m});
next unless($module =~ /^$m\::/);
next unless(!$map->{$module} or $map->{$module} eq $map->{$m});
return 1;
}
return;
}
sub _share_via_extension {
my $self = shift;
my $file = $self->dist_file;
my $share_extension = $self->share_extension;
eval "use $share_extension; 1" or die "This feature requires $share_extension to be installed";
# might die...
if($share_extension eq 'CPAN::Uploader') {
$share_extension->upload_file($file, {
user => $self->pause_info->{user},
password => $self->pause_info->{password},
});
}
else {
$share_extension->upload_file($file, @{ $self->share_params || [] });
}
return 1;
}
sub _generate_file_from_template {
my($self, $file) = @_;
my $content;
if(-e $file and !$self->force) {
$self->_log("$file already exists. (Skipping)");
return;
}
$content = $self->_templates->{$file} or die "No such template defined: $file";
$content =~ s!\$\{(\w+)\}!{ $self->$1 }!ge;
mkdir dirname $file;
open my $FH, '>', $file or die "Write $file: $!";
print $FH $content;
$self->_log("$file was generated");
}
sub _system {
shift->_log("\$ @_");
open STDERR, '>', '/dev/null' if($SILENT);
open STDOUT, '>', '/dev/null' if($SILENT);
system @_; $_ = $?;
open STDERR, '>&', $OLDERR if($SILENT);
open STDOUT, '>&', $OLDOUT if($SILENT);
die "system(@_) == $_" if $_;
return 1;
}
sub _git {
shift->_system(git => @_);
}
sub _make {
my $self = shift;
$self->_generate_file_from_template('Makefile.PL');
$self->_system(perl => 'Makefile.PL') unless(-e 'Makefile');
$self->_system(make => @_);
return 1;
}
sub _log {
return if $SILENT;
print $_[1], "\n";
}
1;
__DATA__
%% t/00-load.t ==============================================================
use lib 'lib';
use Test::More;
eval 'use Test::Compile; 1' or plan skip_all => 'Test::Compile required';
all_pm_files_ok();
%% t/00-pod.t ===============================================================
use lib 'lib';
use Test::More;
eval 'use Test::Pod; 1' or plan skip_all => 'Test::Pod required';
all_pod_files_ok();
%% t/00-pod-coverage.t ======================================================
use lib 'lib';
use Test::More;
eval 'use Test::Pod::Coverage; 1' or plan skip_all => 'Test::Pod::Coverage required';
all_pod_coverage_ok({ also_private => [ qr/^[A-Z_]+$/ ] });
%% MANIFEST.SKIP ============================================================
^mypp.yml
.git
\.old
\.swp
~$
^blib/
^Makefile$
^MANIFEST.*
^${name}
%% .gitignore ===============================================================
/META.yml
/MYMETA.*
/blib/
/inc/
/pm_to_blib
/MANIFEST
/MANIFEST.bak
/Makefile
/Makefile.old
*.old
*.swp
~$
/${name}*tar.gz
%% Changes ==================================================================
Revision history for ${name}
0.01
* Started project
* Add cool feature
%% Makefile.PL ==============================================================
use inc::Module::Install;
name q(${name});
all_from q(${top_module});
${_requires}
bugtracker q(http://rt.cpan.org/NoAuth/Bugs.html?Dist=${name});
homepage q(https://metacpan.org/release/${name});
repository q(${repository});
# install_script glob('bin/*');
auto_install;
WriteAll;
ll;

BEGIN { $INC{'App/Mypp.pm'} = 1 }

#==============================================================================
use Applify;
option bool => init => 'Alias for --update';
option str => update => 'Update repository files' => n_of => '0,';
option bool => test => 'Run unittests';
option bool => build => 'Build a distribution';
option bool => share => 'Push built distribution to CPAN and origin git repo';
option bool => clean => 'Remove generated files by make';
option bool => force => 'Force action, such as overwriting files';
documentation 'App::Mypp';
version 'App::Mypp';
extends 'App::Mypp';
app {
my $self = shift;
my $action = shift || '__UNDEF__';
if($action and $self->can($action)) {
$self->$action($action eq 'update' ? [keys %{ $self->_templates }] : 1);
}
if(@{ $self->update } or $self->init) {
$self->update([keys %{ $self->_templates }]) unless(grep { /\w/ } @{ $self->update });
$self->_generate_file_from_template($_) for reverse sort @{ $self->update };
$self->_system(sprintf '%s %s > %s', 'perldoc -tT', $self->top_module, 'README');
}
elsif($self->test) {
$self->_make('clean');
$self->_generate_file_from_template($_) for grep { m!^t/! } keys %{ $self->_templates };
$self->_make('test');
}
elsif($self->build) {
$self->_build;
}
elsif($self->share) {
my $branch = (qx/git branch/ =~ /\* (.*)$/m)[0];
chomp $branch;
$self->_share_via_extension;
$self->_git(push => origin => $branch);
$self->_git(push => '--tags' => 'origin');
}
elsif($self->clean) {
$self->_make('clean');
}
else {
$self->_script->print_help;
}
return 0;
};
