Module::Release - Automate software releases

	use Module::Release;

	my $release = Module::Release->new( %params );

	# call methods to automate your release process
	$release->check_cvs;
	...

	git://github.com/briandfoy/module-release.git

package Module::Release;

use strict;

use warnings;
no warnings;
use vars qw($VERSION);

$VERSION = '2.05';

use Carp;
use File::Spec;
use Scalar::Util qw(blessed);

my %Loaded_mixins = ( );

sub new
	{
	my( $class, %params ) = @_;

	my $self = bless {}, $class;

	# NOTE: I have to read the configuration to see if I should
	# call the subclass, but I haven't called init yet.
	# Don't set up anything in _read_configuration!
	my $config = $self->_read_configuration;

	if( $config->release_subclass )
		{
		$self->_warn( "Use of release_subclass is deprecated" );
		$self->_die( "release_subclass is the same class! Don't do that!" )
			if $config->release_subclass eq $class;
		my $subclass_self = $self->_handle_subclass(
			$config->release_subclass, %params );

		return $subclass_self;
		}

	$self->init( $config, %params );

	return $self;
	}

sub init
	{	
	my( $self, $config, %params ) = @_;

	$self->_set_defaults( %params );

	# $config comes in as a parameter
	$self->_process_configuration( $config );

	# defer $self->_set_up_web_client;

	1;
	}

sub _select_config_file_name { -e ".releaserc" ? ".releaserc" : "releaserc" }

sub _set_defaults
	{
	require Config;
	require IO::Null;

	my( $self, %params ) = @_;

	my $defaults = {
			'Makefile.PL'  => 'Makefile.PL',
			'Makefile'     => 'Makefile',
			make           => $Config::Config{make},
			manifest       => 'MANIFEST',
			debug          => $ENV{RELEASE_DEBUG} || 0,
			local_file     => undef,
			remote_file    => undef,
			output_fh      => *STDOUT{IO},
			debug_fh       => *STDERR{IO},
			null_fh        => IO::Null->new(),
			quiet          => 0,
			devnull        => File::Spec->devnull,
			ignore_prereqs => '',
			
			%params,
		   };

	foreach my $key ( keys %$defaults )
		{
		$self->{$key} = $defaults->{$key};
		}

	$self->set_perl( $^X );
	$self->add_a_perl( $^X );

	1;
	}

sub _read_configuration
	{
	require ConfigReader::Simple;

	# NOTE: I have to read the configuration to see if I should
	# call the subclass, but I haven't called init yet.
	# Don't set up anything in _read_configuration!
	my $self = shift;

	my $conf_file = $self->_select_config_file_name;

	# Read the configuration
	$self->_die( "Could not find conf file $conf_file\n" )
		unless -e $conf_file;
	my $config = $self->{config} = ConfigReader::Simple->new( $conf_file );
	$self->_die( "Could not get configuration data\n" ) unless ref $config;

	$config;
	}

sub _process_configuration
	{
	my $self = shift;

	# Figure out options
	$self->{cpan} = $self->config->cpan_user eq '<none>' ? 0 : 1;

	$self->{passive_ftp} =
		($self->config->passive_ftp && $self->config->passive_ftp =~ /^y(es)?/) ? 1 : 0;


	{
	my @pairs = (
		[ qw(Makefile.PL makefile_PL) ],
		[ qw(Makefile    makefile)    ],
		[ qw(make        make)        ],
		);
		
	foreach my $pair ( @pairs )
		{
		my( $key, $config ) = @$pair;
		
		$self->{$key} = $self->config->get($config)
			if $self->config->exists($config);
		}
	}
	
	
	my @required = qw(  );

	my $ok = 1;
	for( @required )
		{
		unless( length $self->config->$_() )
			{
			$ok = 0;
			$self->_warn( "Missing configuration data: $_; Aborting!\n" );
			}
		}
	$self->_die( "Missing configuration data" ) unless $ok;


	if( $self->config->perls )
		{
		my @paths = split /:/, $self->config->perls;

		foreach my $path ( @paths )
			{
			$self->add_a_perl( $path );
			}
		}
	}

sub _handle_subclass
	{
	my( $self, $subclass, %params ) = @_;


	# This is a bit tricky. We have to be able to use the subclass, but
	# we don't know if it is defined or not. It might be in a .pm file
	# we haven't loaded, it might be in another file the user already
	# loaded, or the user might have defined it inline inside
	# the script. We'll try loading it if it fails can()
	unless( eval { $subclass->can( 'new' ) } )
		{
		# I don't care if this fails because loading the file
		# might not be the problem
		eval { require File::Spec->catfile( split '::', $subclass ) . '.pm' };
		}

	# If it's not defined by now, we're screwed and we give up
	$self->_die( "$subclass does not have a new()!" )
		unless eval { $subclass->can( 'new' ) };

	my $new_self = eval { $subclass->new( %params ) };
	my $at = $@;

	return $new_self if blessed $new_self;

	$self->_die( "Could not create object with $subclass: $at!" );
	}

sub load_mixin
	{
	my( $self, $module ) = @_;

	return 1 if $self->mixin_loaded( $module );

	no warnings 'redefine';
	
	eval "use $module";

	$self->_die( "Could not load [$module]! $@" ) if $@;

	++$Loaded_mixins{ $module };
	}

sub loaded_mixins { keys %Loaded_mixins }

sub mixin_loaded { exists $Loaded_mixins{ $_[1] } }

sub config { $_[0]->{config} }

sub get_web_user_agent { $_[0]->{web_user_agent} || $_[0]->setup_web_user_agent }

sub setup_web_user_agent 
	{
	my $self = shift;
	
	my $class = $self->web_user_agent_class;
	my $rc = eval { eval "require $class" };
	unless( $rc ) { $self->_die( "Could not load $class: $@" ) };
	
	my $ua = $self->web_user_agent_class->new( 
		agent => $self->web_user_agent_name,
		@_ 
		);

	$ua->cookie_jar( {} );

	$self->{web_user_agent} = $ua;
	}

sub web_user_agent_class { 'LWP::UserAgent' }

sub web_user_agent_name { 'Mozilla' }

sub local_file
	{
	$_[0]->{local_file} = $_[1] if @_ > 1;

	$_[0]->{local_file};
	}

sub remote_file
	{
	$_[0]->{remote_file} = $_[1] if @_ > 1;

	$_[0]->{remote_file};
	}

sub set_perl
	{
	my( $self, $path ) = @_;

	unless( my $version = $self->_looks_like_perl( $path ) )
		{
		$self->_die( "Does not look like a perl [$path]" );
		}

	my $old_perl = $self->get_perl;

	$self->{perl} = $path;

	$old_perl;
	}

sub _looks_like_perl
	{
	my( $self, $path ) = @_;

	my $version = `$path -e "print \$\]" 2>&1`;

	$version =~ m/^\d+\.[\d_]+$/ ? $version : ();
	}

sub get_perl { $_[0]->{perl} }

sub perls
	{
	my $self = shift;

	return keys %{ $self->{perls} };
	}

sub add_a_perl
	{
	my( $self, $path ) = @_;

	return 1 if exists $self->{perls}{$path};

	unless( -x $path )
		{
		$self->_warn( "$path is not executable" );
		return;
		}

	my $version = $self->_looks_like_perl( $path );

	unless( $version )
		{
		$self->_warn( "$path does not appear to be perl!" );
		return;
		}

	return $self->{perls}{$path} = $version;
	}

sub remove_a_perl
	{
	my( $self, $path ) = @_;

	return delete $self->{perls}{$path}
	}

sub reset_perls
	{
	my $self = shift;

	$self->{perls} = {};

	return $self->{perls}{$^X} = $];
	}

sub output_fh  {
	$_[0]->quiet
		?
	$_[0]->null_fh
		:
	( $_[0]->{output_fh} || *STDOUT{IO} )
	}

sub null_fh  { $_[0]->{null_fh} }

sub turn_quiet_on  { $_[0]->{quiet} = 1 }
sub turn_quiet_off { $_[0]->{quiet} = 0 }

sub quiet          { $_[0]->{quiet} }

sub turn_debug_on  { $_[0]->{debug} = 1 }
sub turn_debug_off { $_[0]->{debug} = 0 }

sub debug          { $_[0]->{debug} }

sub debug_fh  {
	$_[0]->debug
		?
	( $_[0]->{debug_fh} || *STDERR{IO} )
		:
	$_[0]->null_fh
	}

sub clean
	{
	my $self = shift;
	$self->_print( "Cleaning directory... " );

	unless( -e $self->{Makefile} )
		{
		$self->_print( " no $self->{Makefile}---skipping\n" );
		return;
		}

	$self->run( "$self->{make} realclean 2>&1" );

	$self->_print( "done\n" );
	}

sub distclean
	{
	my $self = shift;
	$self->_print( "Cleaning directory... " );

	unless( -e $self->{Makefile} )
		{
		$self->_print( " no $self->{Makefile}---skipping\n" );
		return;
		}

	$self->run( "$self->{make} distclean 2>&1" );

	$self->_print( "done\n" );
	}

sub build_makefile
	{
	my $self = shift;
	$self->_print( "Recreating make file... " );

	unless( -e $self->{'Makefile.PL'} )
		{
		$self->_print( " no $self->{'Makefile.PL'}---skipping\n" );
		return;
		}

	$self->run( "$self->{perl} $self->{'Makefile.PL'} 2>&1" );

	$self->_print( "done\n" );
	}

sub make
	{
	my $self = shift;
	$self->_print( "Running make... " );

	unless( -e $self->{'Makefile'} )
		{
		$self->_print( " no $self->{'Makefile'}---skipping\n" );
		return;
		}

	my $tests = $self->run( "$self->{make} 2>&1" );

	$self->_print( "done\n" );
	}

sub test
	{
	my $self = shift;
	$self->_print( "Checking make test... " );

	unless( -e $self->{'Makefile'} )
		{
		$self->_print( " no $self->{'Makefile'}---skipping\n" );
		return;
		}

	my $tests = $self->run( "$self->{make} test 2>&1" );

	$self->_die( "\nERROR: Tests failed!\n$tests\n\nAborting release\n" )
		    unless $tests =~ /All tests successful/;

	$self->_print( "all tests pass\n" );
	}

sub dist
	{
	my $self = shift;
	$self->_print( "Making dist... " );

	unless( -e $self->{'Makefile'} )
		{
		$self->_debug( "no Makefle, so skipping" );
		$self->_print( " no $self->{'Makefile'}---skipping\n" );
		return;
		}

	my $messages = $self->run( "$self->{make} dist 2>&1 < $self->{devnull}" );
	$self->_debug( "messages are [$messages]" );

	# If the distro isn't already set, try to guess it
	unless( $self->local_file )
		{
		$self->_debug( ", guessing local distribution name" );
		my( $guess ) = $messages =~ /^\s*gzip.+?\b'?(\S+\.tar)'?\s*$/m;
		$self->_debug( "guessed [$guess]" );
		$self->local_file( $guess );

		$self->_die( "Couldn't guess distname from dist output\n" )
			unless $self->local_file;

		$self->local_file( $self->local_file() . '.gz' );
		$self->remote_file( $self->local_file );
		}

	# local_file should exist now
	$self->_die( "Local file '$self->{local_file}' does not exist\n" )
		unless -f $self->local_file;

	$self->_print( "done\n" );
	}

sub disttest
	{
	my $self = shift;

	$self->_print( "Checking make disttest... " );

	unless( -e $self->{'Makefile'} )
		{
		$self->_print( " no $self->{'Makefile'}---skipping\n" );
		return;
		}

	my $tests = $self->run( "$self->{make} disttest 2>&1" );

	$self->_die( "\nERROR: Tests failed!\n$tests\n\nAborting release\n" )
		unless $tests =~ /All tests successful/;

	$self->_print( "all tests pass\n" );
	}

sub dist_test
	{
	$_[0]->_warn( "dist_test is deprecated. Use disttest instead." );

	goto &disttest;
	}

sub dist_version
	{
	my $self = shift;

	$self->_die( "Can't get dist_version! It's not set (did you run dist first?)" )
		unless defined $self->remote_file;

	no warnings 'uninitialized';
	my( $major, $minor, $dev ) = $self->remote_file
		=~ /(\d+) \. (\d+)(_\d+)? (?:\. tar \. gz)? $/xg;

	$self->dist_version_format( $major, $minor, $dev );
	}

sub dist_version_format
	{
	no warnings 'uninitialized';
	my $self = shift;
	my( $major, $minor, $dev ) = @_;

	sprintf "%d.%02d%s", $major, $minor, $dev;
	}

# _check_output_lines - for command output with one message per line.
# The message hash identifies the first part of the line and serves
# as a category for the message. If a line doesn't matter, don't put
# it's pattern in the message hash.
#
# Prints a summary of what it found. The message is the hash value
# for that output type.
#
# returns the number of interesting things it found, but that's it.
sub _check_output_lines
	{
	my $self = shift;
	my( $message_hash, $message ) = @_;

	my %state;
	foreach my $state ( keys %$message_hash )
		{
		$state{$state} = [ $message =~ /^\Q$state\E\s+(.+)/gm ];
		}

	my $rule = "-" x 50;
	my $count = 0;

	foreach my $key ( sort keys %state )
		{
		my $list = $state{$key};
		next unless @$list;

		$count += @$list;

		local $" = "\n\t";
		$self->_print( "\n\t$message_hash->{$key}\n\t$rule\n\t@$list\n" );
		}


	return $count;
	}

sub check_manifest
	{
	my $self = shift;

	$self->_print( "Checking state of MANIFEST... " );

	my $manifest = $self->run( "$self->{make} manifest 2>&1" );

	my %message    = (
		"Removed from MANIFEST:"  => 'These files were removed from MANIFEST',
		"Added to MANIFEST:"      => 'These files were added to MANIFEST',
		);

	my $count = $self->_check_output_lines( \%message, $manifest );

	$self->_die( "\nERROR: Manifest was not up-to-date ($count files).\n" )
		if $count;

	$self->_print( "MANIFEST up-to-date\n" );
	}

sub manifest_name { 'MANIFEST' }

sub manifest { 
	$_[0]->_warn( "manifest is deprecated. Use manifest_name" );
	&manifest_name 
	}

sub files_in_manifest
	{
	my $self = shift;
	
	require ExtUtils::Manifest;
	
	# I want to use ExtUtils::Manifest so it automatically
	# follows the right MANIFEST rules, but I have to adapt
	# it's output to my output. Annoying, for sure.
	my $hash = do {
		local $SIG{'__WARN__'} = sub { 
			my $message = shift;
			if( $message =~ m/Debug: (.*)/ )
				{
				$self->_debug( $1 );
				}
			else
				{
				$self->_die( "files_in_manifest: could not open file\n" );
				}
			};
			
		ExtUtils::Manifest::maniread( $self->manifest_name );
		};
	
	sort keys %$hash;
	}

sub check_vcs
	{
	$_[0]->_die( "check_cvs must be implemented in a mixin class" );
	}


sub vcs_tag
	{
	$_[0]->_die( "cvs_tag must be implemented in a mixin class" );
	}

sub make_vcs_tag
	{
	$_[0]->_die( "make_cvs_tag must be implemented in a mixin class" );
	}

sub touch
	{
	my( $self, @files ) = @_;
	
	my $time = time;

	my $count = 0;
	foreach my $file ( @files )
		{
		unless( -f $file )
			{
			$self->_warn( "$file is not a plain file" );
			next;
			}

		open my( $fh ), ">>", $file
			or $self->_warn( "Could not open file [$file] for writing: $!" );
		close $file;

		utime( $time, $time, $file );

		# check that it actually worked
		unless( 2 == grep { $_ == $time } (stat $file)[8,9] )
			{
			$self->_warn( "$file did not set utimes." );
			next;
			}

		$count++;
		}

	$count;
	}

sub touch_all_in_manifest { $_[0]->touch( $_[0]->files_in_manifest ) }

sub check_for_passwords
	{
	if( my $pass = $_[0]->config->cpan_user && $_[0]->get_env_var( "CPAN_PASS" )  )
		{
		$_[0]->config->set( 'cpan_pass', $pass ); 
		}
		
	$_[0]->_debug( "CPAN pass is " . $_[0]->config->cpan_pass );
	}

sub get_readme
	{
	open my $fh, '<README' or return '';
	my $data = do {
		local $/;
		<$fh>;
		};

	return $data;
	}

sub get_changes
	{
	open my $fh, '<', 'Changes' or return '';

	my $data = <$fh>;  # get first line

	while( <$fh> )
		{
		last if /^\S/;
		$data .= $_;
		}

	return $data;
	}

sub _run_error_reset { $_[0]->{_run_error} = 0 }
sub _run_error_set   { $_[0]->{_run_error} = 1 }
sub run_error        { $_[0]->{_run_error}     }

sub run
	{
	my( $self, $command ) = @_;

	$self->_run_error_reset;

	$self->_debug( "$command\n" );
	$self->_die( "Didn't get a command!" ) unless defined $command;
	
	open my($fh), "$command |" or $self->_die( "Could not open command [$command]: $!" );
	$fh->autoflush;

	my $output = '';
	my $buffer = '';
	local $| = 1;

	my $readlen = $self->debug ? 1 : 256;

	while( read $fh, $buffer, $readlen )
		{
		$output .= $_;
		$self->_debug( $_, $buffer );
		$output .= $buffer;
		}

	$self->_debug( $self->_dashes, "\n" );

	unless( close $fh )
		{
		$self->_run_error_set;
		$self->_warn(  "Command [$command] didn't close cleanly: $?" );
		}

	return $output;
	}

sub get_env_var
	{
	my ($self, $field) = @_;

	# Check for an explicit argument passed
	return $self->{lc $field} if defined $self->{lc $field};

	my $pass = $ENV{$field};

	return $pass if defined( $pass ) && length( $pass );

	$self->_print( "$field is not set.  Enter it now: " );
	$pass = <>;
	chomp $pass;

	return $pass if defined( $pass ) && length( $pass );

	$self->_debug( "$field not supplied.  Aborting...\n" );
	}

sub _print { print { $_[0]->output_fh } @_[1..$#_] }

sub _dashes { "-" x 73 }

sub _debug { print { $_[0]->debug_fh } @_[1..$#_] }

sub _die { croak @_[1..$#_] }

sub _warn { carp @_[1..$#_] unless $_[0]->quiet }

1;

__END__