#!/usr/bin/env perl
package App::Mypp;
use Cwd;
use File::Basename;
use File::Find;
our $VERSION = '0.08';
our $SILENT = $ENV{'SILENT'} || 0;
our $MAKEFILE_FILENAME = 'Makefile.PL';
our $CHANGES_FILENAME = 'Changes';
our $PAUSE_FILENAME = $ENV{'HOME'} .'/.pause';
our $VERSION_RE = qr/\d+ \. [\d_]+/x;
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 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 {
my $self = shift;
return $self->_filename_to_module($self->top_module);
};
_attr changes => sub {
my $self = shift;
my($text, $version);
unless(-e $CHANGES_FILENAME) {
open my $CHANGES, '>', $CHANGES_FILENAME or die "Write '$CHANGES_FILENAME': $!\n";
printf $CHANGES "Revision history for %s\n\n0.00\n", $self->name;
print $CHANGES " " x 7, "* Init repo\n\n";
print "Wrote $CHANGES_FILENAME\n";
}
open my $CHANGES, '<', $CHANGES_FILENAME or die "Read '$CHANGES_FILENAME': $!\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_FILENAME\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 {
my $self = shift;
my $info;
open my $PAUSE, '<', $PAUSE_FILENAME or die "Read $PAUSE_FILENAME: $!\n";
while(<$PAUSE>) {
my($k, $v) = split /\s+/, $_, 2;
chomp $v;
$info->{$k} = $v;
}
die "'user <name>' is not set in $PAUSE_FILENAME\n" unless $info->{'user'};
die "'password <mysecret>' is not set in $PAUSE_FILENAME\n" unless $info->{'password'};
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;
};
_attr perl5lib => sub {
my $self = shift;
my $inc = $self->config->{'perl5lib'};
if(!$inc) {
$inc = [];
}
elsif(ref $inc ne 'ARRAY') {
$inc = [ split /:/, $inc ];
}
if($ENV{'PERL5LIB'}) {
warn 'perl5lib attribute is not set using PERL5LIB environment variable'
}
return $inc;
};
_attr _eval_package_requires => sub {
eval q(package __EVAL__;
no warnings "redefine";
our @REQUIRES;
sub use { push @REQUIRES, @_ }
sub require { push @REQUIRES, @_ }
sub base { push @REQUIRES, @_ }
sub extends { push @REQUIRES, @_ }
sub with { push @REQUIRES, @_ }
1;
) or die $@;
return \@__EVAL__::REQUIRES;
};
sub new {
my $class = shift;
my $self = bless {}, $class;
unshift @INC, @{ $self->perl5lib };
return $self;
}
sub timestamp_to_changes {
my $self = shift;
my $date = qx/date/; # ?!?
my($changes, $pm);
chomp $date;
open my $CHANGES, '+<', $CHANGES_FILENAME or die "Read/write '$CHANGES_FILENAME': $!\n";
{ local $/; $changes = <$CHANGES> };
if($changes =~ s/\n($VERSION_RE)\s*$/{ sprintf "\n%-7s  %s", $1, $date }/em) {
seek $CHANGES, 0, 0;
print $CHANGES $changes;
print "Add timestamp '$date' to $CHANGES_FILENAME\n" unless $SILENT;
return 1;
}
die "Unable to update $CHANGES_FILENAME 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 '$top_module': $!\n";
{ local $/; $top_module_text = <$MODULE> };
}
$top_module_text =~ s/=head1 VERSION.*?\n=/=head1 VERSION\n\n$version\n\n=/s;
$top_module_text =~ s/^((?:our)?\s*\$VERSION)\s*=.*$/$1 = '$version';/m;
{
open my $MODULE, '>', $top_module or die "Write '$top_module': $!\n";
print $MODULE $top_module_text;
}
print "Update version in '$top_module' to $version\n" unless $SILENT;
return 1;
}
sub generate_readme {
my $self = shift;
return $self->_vsystem(
sprintf '%s %s > %s', 'perldoc -tT', $self->top_module, 'README'
) ? 0 : 1;
}
sub clean {
my $self = shift;
my $name = $self->name;
$self->_vsystem('make clean 2>/dev/null');
$self->_vsystem(sprintf 'rm -r %s 2>/dev/null', join(' ',
"$name*",
qw(
blib/
inc/
Makefile
Makefile.old
MANIFEST*
META.yml
MYMETA.yml
),
));
return 1;
}
sub makefile {
my $self = shift;
my $name = $self->name;
my(%requires, $repo);
die "$MAKEFILE_FILENAME already exist\n" if(-e $MAKEFILE_FILENAME);
open my $MAKEFILE, '>', $MAKEFILE_FILENAME or die "Write '$MAKEFILE_FILENAME': $!\n";
printf $MAKEFILE "use inc::Module::Install;\n\n";
printf $MAKEFILE "name q(%s);\n", $self->name;
printf $MAKEFILE "all_from q(%s);\n", $self->top_module;
if(%requires = $self->requires('lib')) {
print $MAKEFILE "\n";
}
for my $name (sort keys %requires) {
printf $MAKEFILE "requires q(%s) => %s;\n", $name, $requires{$name};
}
if(%requires = $self->requires('t')) {
print $MAKEFILE "\n";
}
for my $name (sort keys %requires) {
printf $MAKEFILE "test_requires q(%s) => %s;\n", $name, $requires{$name};
}
$repo = (qx/git remote show -n origin/ =~ /URL: (.*)$/m)[0] || 'git://github.com/';
$repo =~ s#^[^:]+:#git://github.com/#;
print $MAKEFILE "\n";
print $MAKEFILE "bugtracker q(http://rt.cpan.org/NoAuth/Bugs.html?Dist=$name);\n";
print $MAKEFILE "homepage q(http://search.cpan.org/dist/$name);\n";
print $MAKEFILE "repository q($repo);\n";
print $MAKEFILE "\n";
print $MAKEFILE "catalyst;\n" if($INC{'Catalyst.pm'});
print $MAKEFILE "# install_script glob('bin/*');\n";
print $MAKEFILE "auto_install;\n";
print $MAKEFILE "WriteAll;\n";
print "Wrote $MAKEFILE_FILENAME\n" unless $SILENT;
return 1;
}
sub requires {
my $self = shift;
my $dir = shift;
my $prefix = $self->top_module_name;
my %requires;
local @INC = ('lib', @INC);
finddepth({
no_chdir => 1,
wanted => sub {
return if(!-f $_);
return if(/\.swp/);
return $self->_pm_requires($_ => \%requires) if(/\.pm$/);
return $self->_script_requires($_ => \%requires);
},
}, $dir);
for my $module (keys %requires) {
delete $requires{$module} if($module =~ /^$prefix/);
}
return %requires if(wantarray);
return \%requires;
}
sub _pm_requires {
my $self = shift;
my $file = shift;
my $requires = shift;
my $required_module = $self->_filename_to_module($file);
my @modules;
{
local $SIG{'__WARN__'} = sub { print $_[0] unless($_[0] =~ /\sredefined\sat/)};
local @INC = (sub {
my $module = $self->_filename_to_module(pop);
push @modules, $module if(caller(0) =~ /^$required_module/);
}, @INC);
eval "use $required_module (); 1" or warn $@;
return if($@);
}
if(my $meta = eval "$required_module\->meta") {
if($meta->isa('Class::MOP::Class')) {
push @modules, $meta->superclasses, map { split /\|/, $_->name } @{ $meta->roles };
}
else {
push @modules, map { split /\|/, $_->name } @{ $meta->get_roles };
}
}
else {
push @modules, eval "\@$required_module\::ISA";
}
for my $m (@modules) {
my($module, $version) = $self->_version_from_module($m) or next;
$requires->{$module} = $version;
}
return 1;
}
sub _script_requires {
my $self = shift;
my $file = shift;
my $requires = shift;
my $modules = $self->_eval_package_requires;
open my $FH, '<', $file or die "Read $file: $!\n";
local @$modules = ();
while(<$FH>) {
if(/^\s*use \s ([A-Z]\S+) ;/x) {
eval "__EVAL__::use('$1');" or warn "$1 => $@";
}
elsif(/^\s*require \s ([A-Z]\S+) ;/x) {
eval "__EVAL__::require('$1');" or warn "$1 => $@";
}
elsif(/^\s*use \s (base .*) ;/x) {
eval "__EVAL__::$1;" or warn "$1 => $@";
}
elsif(/^\s*(extends [\(\s] .*)/x) {
eval "__EVAL__::$1;" or warn "$1 => $@";
}
elsif(/^\s*(with [\(\s] .*)/x) {
eval "__EVAL__::$1;" or warn "$1 => $@";
}
}
for my $m (@$modules) {
local $SIG{'__WARN__'} = sub { print $_[0] unless($_[0] =~ /\sredefined\sat/)};
eval "use $m (); 1" or warn $@;
my($module, $version) = $self->_version_from_module($m) or next;
$requires->{$module} = $version;
}
return 1;
}
sub manifest {
my $self = shift;
open my $SKIP, '>', 'MANIFEST.SKIP' or die "Write 'MANIFEST.SKIP': $!\n";
print $SKIP "$_\n" for qw(
^mypp.yml
.git
\.old
\.swp
~$
^blib/
^Makefile$
^MANIFEST.*
), $self->name;
$self->make('manifest') and die "Execute 'make manifest' failed\n";
return 1;
}
sub make {
my $self = shift;
$self->makefile unless(-e $MAKEFILE_FILENAME);
$self->_vsystem(perl => $MAKEFILE_FILENAME) unless(-e 'Makefile');
$self->_vsystem(make => @_);
}
sub tag_and_commit {
my $self = shift;
$self->_vsystem(git => commit => -a => -m => $self->changes->{'text'});
$self->_vsystem(git => tag => $self->changes->{'version'});
return 1;
}
sub share_via_git {
my $self = shift;
my $branch = (qx/git branch/ =~ /\* (.*)$/m)[0];
chomp $branch;
$self->_vsystem(git => push => origin => $branch);
$self->_vsystem(git => push => '--tags' => 'origin');
return 1;
}
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') {
my $pause = $self->pause_info;
$share_extension->upload_file($file, {
user => $pause->{'user'},
password => $pause->{'password'},
});
}
else {
$share_extension->upload_file($file, @{ $self->share_params || [] });
}
return 1;
}
sub t_pod {
my $self = shift;
my $coverage = -e 't/99-pod-coverage.t' ? 't/99-pod-coverage.t' : 't/00-pod-coverage.t';
my $pod = -e 't/99-pod.t' ? 't/99-pod.t' : 't/00-pod.t';
mkdir 't';
open my $POD_COVERAGE, '>', $coverage or die "Write '$coverage': $!\n";
print $POD_COVERAGE $self->_t_header;
print $POD_COVERAGE <<'TEST';
eval 'use Test::Pod::Coverage; 1' or plan skip_all => 'Test::Pod::Coverage required';
all_pod_coverage_ok({ also_private => [ qr/^[A-Z_]+$/ ] });
TEST
print "Wrote $coverage\n" unless $SILENT;
open my $POD, '>', $pod or die "Write '$pod': $!\n";
print $POD $self->_t_header;
print $POD <<'TEST';
eval 'use Test::Pod; 1' or plan skip_all => 'Test::Pod required';
all_pod_files_ok();
TEST
print "Wrote $pod\n" unless $SILENT;
return 1;
}
sub t_load {
my $self = shift;
my @modules;
finddepth(sub {
return unless($File::Find::name =~ /\.pm$/);
$File::Find::name =~ s,.pm$,,;
$File::Find::name =~ s,lib/?,,;
$File::Find::name =~ s,/,::,g;
push @modules, $File::Find::name;
}, 'lib');
mkdir 't';
open my $USE_OK, '>', 't/00-load.t' or die "Write 't/00-load.t': $!\n";
print $USE_OK $self->_t_header;
printf $USE_OK "plan tests => %i;\n", int @modules;
for my $module (sort { $a cmp $b } @modules) {
printf $USE_OK "use_ok('%s');\n", $module;
}
print "Wrote t/00-load.t\n" unless $SILENT;
return 1;
}
sub _t_header {
my $self = shift;
my @lib = ('lib', @{ $self->perl5lib });
return <<"HEADER";
#!/usr/bin/env perl
use lib qw(@lib);
use Test::More;
HEADER
}
sub help {
print '
 Usage mypp [option]

 -update
  * Update version information in main module
  * Create/update t/00-load.t and t/00-pod*t
  * Create/update README

 -test
  * Create/update t/00-load.t and t/00-pod*t
  * Test the project

 -build
  * Same as -update
  * Update Changes with release date
  * Create MANIFEST* and META.yml
  * Tag and commit the changes (locally)
  * Build a distribution (.tar.gz)

 -share
  * Push commit and tag to "origin"
  * Upload the disted file to CPAN

 -clean
  * Remove files and directories which should not be included
    in the project repo

 -makefile
  * Create "Makefile.PL" from plain guesswork

 -changes
  * Create "Changes" from template

 -version
  * Display the version number for for mypp

 -man
  * Display manual for mypp

';
}sub _vsystem {
shift; # shift off class/object
print "\$ @_\n" unless $SILENT;
return $SILENT ? system "@_ 1>/dev/null 2>/dev/null" : system @_;
}
sub _filename_to_module {
local $_ = $_[1];
s,\.pm,,;
s,^/?lib/,,g;
s,/,::,g;
return $_;
}
sub _version_from_module {
my $self = shift;
my $module = shift;
while($module) {
if(my $version = eval "\$$module\::VERSION") {
return($module, $version);
}
$module =~ s/::\w+$// or last;
}
return;
}
1;

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

#==============================================================================
use Data::Dumper;
eval "use App::Mypp; 1" or die "Could not load App::Mypp: $@";
my $app = App::Mypp->new;
my $action = shift @ARGV or exit $app->help;
my $method = $action;
$action =~ s/^-+//;
$method =~ s/^-+//;
$method =~ s/-/_/g;
if($action eq 'update') {
$app->clean;
$app->update_version_info;
$app->t_load;
$app->t_pod;
$app->generate_readme;
}
elsif($action eq 'test') {
$app->clean;
$app->t_load;
$app->t_pod;
$app->make('test');
}
elsif($action eq 'build') {
$app->clean;
$app->t_load;
$app->t_pod;
$app->timestamp_to_changes;
$app->update_version_info;
$app->generate_readme;
$app->manifest;
$app->tag_and_commit;
$app->_vsystem('rm ' .$app->name .'* 2>/dev/null');
$app->make('dist');
}
elsif($action eq 'share') {
$app->share_via_extension;
$app->share_via_git;
}
elsif($app->can($method)) {
if(my $res = $app->$method(@ARGV)) {
if(ref $res) {
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Terse = 1;
print Dumper $res;
}
elsif($res eq '1') {
exit 0;
}
else {
print $res, "\n";
}
}
else {
die "Failed to execute $app->$method\n";
}
}
elsif($action eq 'version') {
print "App-Mypp version: ", $App::Mypp::VERSION, "\n";
}
elsif($action eq 'man') {
if($0 eq '-') {
print "Read manual online: http://jhthorsen.github.com/app-mypp\n"
}
else {
exec perldoc => $0;
}
}
else {
exit $app->help;
}
exit 0;
