view release on metacpan or  search on metacpan

lib/App/ModuleBuildTiny.pm  view on Meta::CPAN

	my $template = get_data_section('Changes');
	my $content = fill_in($template, \%opts);
	write_text('Changes', $content);
}

sub write_maniskip {
	my $distname = shift;
	write_text('MANIFEST.SKIP', "#!include_default\n$distname-.*\nREADME.pod\n");
}

sub write_readme {
	my %opts = @_;
	my $template = get_data_section('README');
	write_text('README', fill_in($template, \%opts));
}

sub read_json {
	my $filename = shift;
	-f $filename or return;
	return decode_json(read_binary($filename));
}

sub write_json {
	my ($filename, $content) = @_;
	my $dirname = dirname($filename);
	mkdir $dirname if not -d $dirname;
	my $json = JSON::MaybeXS->new->utf8->pretty->canonical->encode($content);
	return write_binary($filename, $json);
}

sub bump_versions {
	my (%opts) = @_;
	require App::RewriteVersion;
	my $app = App::RewriteVersion->new(%opts);
	my $trial = delete $opts{trial};
	my $new_version = defined $opts{version} ? delete $opts{version} : $app->bump_version($app->current_version);
	$app->rewrite_versions($new_version, is_trial => $trial);
}

sub insert_options {
	my ($opts, $config) = @_;
	$opts->{add_repository} = !!$config->{auto_repo};
	$opts->{add_bugtracker} = !!$config->{auto_tracker};
}

sub regenerate {
	my ($files, $config, %opts) = @_;
	my %files = map { $_ => 1 } @{$files};
	my @dirty = @{$files};

	if ($opts{bump}) {
		bump_versions(%opts);
		$files{'Changes'}++;
		push @dirty, 'Changes';
	}

	insert_options(\%opts, $config);
	my $dist = App::ModuleBuildTiny::Dist->new(%opts, regenerate => \%files);
	my @generated = grep { $files{$_} } $dist->files;
	for my $filename (@generated) {
		say "Updating $filename" if $opts{verbose};
		write_binary($filename, $dist->get_file($filename)) if !$opts{dry_run};
	}

	if ($opts{commit}) {
		require Git::Wrapper;
		my $git = Git::Wrapper->new('.');
		if ($opts{bump}) {
			push @dirty, 'lib';
			push @dirty, 'script' if -d 'script';
		}
		my $allowed = join '|', map qr{^\Q$_\E$}, @dirty;
		my @modified = grep /$allowed/, $git->ls_files({ modified => 1 });

		if (@modified) {
			my @changes = $dist->get_changes;
			my $version = 'v' . $dist->version;
			my $message = $opts{message} || ($opts{bump} ? join '', $version, "\n\n", @changes : 'Regenerate');
			$git->commit({ m => $message }, @dirty);
		} else {
			say "No modifications to commit";
		}
	}
}

my %prompt_for = (
	open => \&prompt,
	yn => \&prompt_yn,
);

my @config_items = (
	[ 'author'        , 'What is the author\'s name?', 'open' ],
	[ 'email'         , 'What is the author\'s email?', 'open',  ],
	[ 'license'       , 'What license do you want to use?', 'open', 'Perl_5' ],

	[ 'write_buildpl' , 'Do you want to write your Build.PL file to your filesystem?', 'yn', !!1],
	[ 'write_meta'    , 'Do you want to write your meta files to your filesystem?', 'yn', !!1],
	[ 'write_manifest', 'Do you want to write your manifest files to your filesystem?', 'yn', !!1],
	[ 'write_license' , 'Do you want to write your LICENSE file to your filesystem?', 'yn', !!1],
	[ 'write_readme'  , 'Do you want to write your README file to your filesystem?', 'yn', !!1],

	[ 'auto_git'      , 'Do you want mbtiny to automatically handle git for you?', 'yn', !!1 ],
	[ 'auto_bump'     , 'Do you want mbtiny to automatically bump on regenerate for you?', 'yn', !!1 ],
	[ 'auto_scan'     , 'Do you want mbtiny to automatically scan dependencies for you?', 'yn', !!1 ],
	[ 'auto_repo'     , 'Do you want mbtiny to automatically add a repository link to the metadata', 'yn', !!1 ],
	[ 'auto_tracker'  , 'Do you want mbtiny to automatically add a bugtracker link to the metadata', 'yn', !!1 ],
);

my %fallback_config = (
	'write_buildpl'  => 'write_build',
	'write_meta'     => 'write_build',
	'write_manifest' => 'write_build',
);

my @delete_config = qw/write_build/;

sub ask {
	my ($config, $item, $local_default) = @_;
	my ($key, $description, $type, $global_default) = @{$item};
	my $value = $prompt_for{$type}->($description, $local_default // $global_default);

	if ($value ne '-') {
		$config->{$key} = $type eq 'open' ? $value : $value ? JSON::MaybeXS::true : JSON::MaybeXS::false;
	}
	else {
		delete $config->{$key};
	}
}

sub show_item {
	my ($config, $key, $type) = @_;
	return defined $config->{$key} ? $type eq 'open' ? $config->{$key} : $config->{$key} ? 'true' : 'false' : '(undefined)';
}

sub get_settings_file {
	local $HOME = $USERPROFILE if $^O eq 'MSWin32';
	return catfile(glob('~'), qw/.mbtiny conf/);
}

my %default_settings = (
	auto_bump     => 1,

lib/App/ModuleBuildTiny.pm  view on Meta::CPAN

		my $sure = prompt_yn('Do you want to continue the release process?', !!0);
		if ($sure) {
			my $file = $dist->write_tarball($dist->archivename);
			require CPAN::Upload::Tiny;
			CPAN::Upload::Tiny->VERSION('0.009');
			my $uploader = CPAN::Upload::Tiny->new_from_config_or_stdin($opts{config});
			$uploader->upload_file($file);
			print "Successfully uploaded $file\n" if not $opts{silent};

			if ($opts{tag}) {
				require Git::Wrapper;
				my $git = Git::Wrapper->new('.');
				my $version = 'v' . $dist->version;
				$git->tag('-m' => $version, $version);
			}

			if (defined $opts{push} and not $opts{nopush}) {
				require Git::Wrapper;
				my $git = Git::Wrapper->new('.');

				my @remote = length $opts{push} ? $opts{push} : ();
				$git->push(@remote);
				$git->push({ tags => 1 }, @remote) if $opts{tag};
			}
		}
		return 0;
	},
	run => sub {
		my @arguments = @_;
		die "No arguments given to run\n" if not @arguments;
		GetOptionsFromArray(\@arguments, 'build!' => \(my $build = 1), 'allow_failure|allow-failure!' => \my $allow_failure) or return 2;
		insert_options(\my %opts, get_config);
		my $dist = App::ModuleBuildTiny::Dist->new(%opts);
		return $dist->run(commands => [ [ $SHELL ] ], build => $build, verbose => 0, allow_failure => $allow_failure);
	},
	shell => sub {
		my @arguments = @_;
		GetOptionsFromArray(\@arguments, 'build!' => \my $build, 'allow_failure|allow-failure!' => \my $allow_failure) or return 2;
		insert_options(\my %opts, get_config);
		my $dist = App::ModuleBuildTiny::Dist->new(%opts);
		return $dist->run(commands => [ [ $SHELL ] ], build => $build, verbose => 0, allow_failure => $allow_failure);
	},
	listdeps => sub {
		my @arguments = @_;
		GetOptionsFromArray(\@arguments, \my %opts, qw/json only_missing|only-missing|missing omit_core|omit-core=s author versions/) or return 2;
		insert_options(\%opts, get_config);
		my $dist = App::ModuleBuildTiny::Dist->new(%opts);

		require CPAN::Meta::Prereqs::Filter;
		my $prereqs = CPAN::Meta::Prereqs::Filter::filter_prereqs($dist->meta->effective_prereqs, %opts);

		if (!$opts{json}) {
			my @phases = qw/build test configure runtime/;
			push @phases, 'develop' if $opts{author};

			my $reqs = $prereqs->merged_requirements(\@phases);
			$reqs->clear_requirement('perl');

			my @modules = sort { lc $a cmp lc $b } $reqs->required_modules;
			if ($opts{versions}) {
				say "$_ = ", $reqs->requirements_for_module($_) for @modules;
			}
			else {
				say for @modules;
			}
		}
		else {
			print JSON::MaybeXS->new->ascii->canonical->pretty->encode($prereqs->as_string_hash);
		}
		return 0;
	},
	regenerate => sub {
		my @arguments = @_;
		my $config = get_config;
		my %opts;
		GetOptionsFromArray(\@arguments, \%opts, qw/trial bump! version=s verbose dry_run|dry-run commit! scan! message=s/) or return 2;
		my @files = @arguments ? @arguments : regenerate_files($config);
		if (!@arguments) {
			$opts{bump}   //= $config->{auto_bump};
			$opts{commit} //= $config->{auto_git};
			$opts{scan}   //= $config->{auto_scan};
		}

		regenerate(\@files, $config, %opts);

		return 0;
	},
	scan => sub {
		my @arguments = @_;
		my %opts = (sanitize => 1);
		GetOptionsFromArray(\@arguments, \%opts, qw/omit_core|omit-core=s sanitize! omit=s@/) or return 2;
		insert_options(\%opts, get_config);
		my $dist = App::ModuleBuildTiny::Dist->new(%opts, regenerate => { 'META.json' => 1 });
		my $prereqs = $dist->scan_prereqs(%opts);
		write_json('prereqs.json', $prereqs->as_string_hash);
		return 0;
	},
	setup => sub {
		my @arguments = @_;
		my $config_file = get_settings_file();
		my $config = -f $config_file ? read_json($config_file) : {};

		my $mode = @arguments ? shift @arguments : 'upgrade';

		if ($mode eq 'upgrade') {
			for my $item (@config_items) {
				next if defined $config->{ $item->[0] };
				my $default = $config->{ $fallback_config{ $item->[0] } // '' };
				ask($config, $item, $default);
			}
			# delete $config->{$_} for @delete_config;
			write_json($config_file, $config);
		}
		elsif ($mode eq 'minimal') {
			for my $item (@config_items) {
				next if defined $config->{ $item->[0] };
				if (defined $item->[3]) {
					$config->{ $item->[0] } = $item->[3];
				} else {
					ask($config, $item);
				}
			}
			delete $config->{$_} for @delete_config;
			write_json($config_file, $config);
		}
		elsif ($mode eq 'all') {
			for my $item (@config_items) {
				my $default = $config->{ $item->[0] } // $config->{ $fallback_config{ $item->[0] } // '' };
				ask($config, $item, $default);
			}
			delete $config->{$_} for @delete_config;
			write_json($config_file, $config);
		}
		elsif ($mode eq 'get') {
			my ($key, $value) = @arguments;
			my ($item) = grep { $_->[0] eq $key } @config_items;
			die "No such known key $key" if not $item;
			my (undef, $description, $type, $default) = @{$item};
			say show_item($config, $key, $type);
		}
		elsif ($mode eq 'set') {
			my ($key, $value) = @arguments;
			my $item = grep { $_->[0] eq lc $key } @config_items;
			die "No such known key $key" if not $item;
			if ($item->[2] eq 'yn') {
				$config->{$key} = $boolean{$value} // die "Unknown boolean value '$value'\n";
			} else {
				$config->{$key} = $value;
			}
			write_json($config_file, $config);
		}
		elsif ($mode eq 'list') {
			for my $item (@config_items) {
				my ($key, $description, $type, $default) = @{$item};
				say "$key: " . show_item($config, $key, $type);
			}
		}
		elsif ($mode eq 'reset') {
			return not unlink $config_file;
		}
		return 0;
	},
	config => sub {
		my @arguments = @_;
		my $settings = get_settings;
		my $config = get_config;

		my $mode = @arguments ? shift @arguments : 'upgrade';

		my @items = grep { $_->[2] ne 'open' } @config_items;
		if ($mode eq 'upgrade') {
			for my $item (@items) {
				next if defined $config->{ $item->[0] };
				my $default = $config->{ $fallback_config{ $item->[0] } // '' };
				ask($config, $item, $default);
			}
			delete $config->{$_} for @delete_config;
			write_json($config_file, $config);
		}
		elsif ($mode eq 'all') {
			for my $item (@items) {
				my $default = $config->{ $item->[0] } // $config->{ $fallback_config{ $item->[0] } // '' } // $settings->{ $item->[0] };
				ask($config, $item, $default);
			}
			delete $config->{$_} for @delete_config;
			write_json($config_file, $config);
		}
		elsif ($mode eq 'copy') {
			for my $item (@items) {
				my ($key) = @{$item};
				$config->{$key} = $settings->{$key} if exists $settings->{$key};
			}
			write_json($config_file, $config);
		}
		elsif ($mode eq 'get') {
			my ($key, $value) = @arguments;
			my ($item) = grep { $_->[0] eq $key } @config_items;
			die "No such known key $key" if not $item;
			my (undef, $description, $type, $default) = @{$item};
			say show_item($config, $key, $type);
		}
		elsif ($mode eq 'set') {
			my ($key, $value) = @arguments;
			my $item = grep { $_->[0] eq lc $key } @config_items;
			die "No such known key $key" if not $item;
			$config->{$key} = $boolean{$value} // die "Unknown boolean value '$value'\n";
			write_json($config_file, $config);
		}
		elsif ($mode eq 'list') {
			for my $item (@items) {
				my ($key, $description, $type, $default) = @{$item};
				say "$key: " . show_item($config, $key, $type);
			}
		}
		elsif ($mode eq 'reset') {
			return not unlink $config_file;
		}
		return 0;
	},
	mint => sub {
		my @arguments = @_;

		my $settings = get_settings(\%default_settings);

		my $distname = decode_utf8(shift @arguments // die "No distribution name given\n") =~ s/::/-/gr;

		my %args = (
			author   => $settings->{author},
			email    => $settings->{email},
			license  => $settings->{license},
			version  => '0.000',
			dirname  => $distname,
			abstract => 'INSERT YOUR ABSTRACT HERE',
			init_git => $settings->{auto_git},
		);
		my %config;
		my @options = qw/version=s abstract=s dirname=s init_git|init-git/;
		for my $config_item (@config_items) {
			my $entry = $config_item->[0] =~ s{^(\w+_\w+)\K$}{ '|' . $1 =~ tr/_/-/r }er;
			push @options, $entry . ($config_item->[2] eq 'yn' ? '!' : '=s');
		}
		GetOptionsFromArray(\@arguments, \%args, @options) or return 2;
		for my $item (@config_items) {
			my ($key, $description, $type, $default) = @{$item};
			if ($type eq 'open') {
				$args{$key} //= prompt($description, $default);
			}
			else {
				$config{$key} = $args{$key} // $settings->{$key} // prompt_yn($description, $default);
			}
		}

		my $license = create_license_for(delete $args{license}, $args{author});

		die "Directory $args{dirname} already exists\n" if -e $args{dirname};
		mkdir $args{dirname};
		chdir $args{dirname};
		$args{module_name} = $distname =~ s/-/::/gr;

		my $module_file = write_module(%args, notice => $license->notice);
		write_changes(%args, distname => $distname);
		write_maniskip($distname);
		write_json('dist.json', \%config);
		mkdir 't';

		write_json('metamerge.json', { name => $distname }) if $distname ne $args{dirname};

		my @regenerate_files = regenerate_files(\%config);
		regenerate(\@regenerate_files, \%args, scan => $config{auto_scan});

		if ($args{init_git}) {
			my $ignore = join "\n", qw/*.bak *.swp *.swo *.tdy *.tar.gz/, "$distname-*", '';
			write_text('.gitignore', $ignore);

			require Git::Wrapper;
			my $git = Git::Wrapper->new('.');
			$git->init;
			$git->add(@regenerate_files, 'Changes', 'MANIFEST.SKIP', 'dist.json', '.gitignore', $module_file, grep -e, 'metamerge.json');
			$git->commit({ message => 'Initial commit' });
		}

		return 0;
	},
	version => sub {
		say $VERSION;
	},
);

sub modulebuildtiny {
	my ($action, @arguments) = @_;
	die "No action given\n" unless defined $action;
	my $call = $actions{$action};
	die "No such action '$action' known\n" if not $call;
	return $call->(@arguments);
}

1;

=head1 NAME

App::ModuleBuildTiny - A standalone authoring tool for Module::Build::Tiny and Dist::Build

=head1 DESCRIPTION

App::ModuleBuildTiny contains the implementation of the L<mbtiny> tool.

=head1 FUNCTIONS

=over 4

=item * modulebuildtiny($action, @arguments)

This function runs a modulebuildtiny command. It expects at least one argument: the action. It may receive additional ARGV style options dependent on the command.

The actions are documented in the L<mbtiny> documentation.

=back

=head1 SEE ALSO

=head2 Similar programs

=over 4

=item * L<Dist::Zilla|Dist::Zilla>

An extremely powerful but somewhat heavy authoring tool.

=item * L<Minilla|Minilla>

A more minimalistic than Dist::Zilla but still somewhat customizable authoring tool.

=back

=head1 AUTHOR

Leon Timmermans <leont@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011 by Leon Timmermans.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.