Perl Module Checklist

perl_module_checklist.pl

#!/usr/bin/perl
use strict;
use warnings;

use vars qw( $Longest_name );

use Data::Dumper;
use File::Spec::Functions qw(catfile);
use Spreadsheet::WriteExcel;
use Test::Manifest qw(get_t_files);
use Tie::Cycle;

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #	
my %modules = ();
my $Longest_name = 0;

my $workbook = Spreadsheet::WriteExcel->new("/Users/brian/Desktop/modules.xls");
my $worksheet = $workbook->add_worksheet("Modules");

write_headers( $worksheet );

my $base = "/Users/brian/Dev";


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #	
unless( @ARGV )
	{
	@ARGV =  map { File::Spec->rel2abs( $_, $base ) } 
		( qw(HTTP/Size), 
		map { "HTTP/Cookies/$_" } qw(iCab Safari Omniweb Mozilla) );
	}

print "Checking @ARGV\n";

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #	
foreach my $row ( 0 .. $#ARGV )
{
my $directory = $ARGV[$row];

print "Processing $directory...\n";
chdir $directory or do { warn "Cannot chdir to $directory!\n$!\n"; next };

my $module = $directory;
$module =~ s|$base/||g;
$module =~ s|/|::|g;

my $hash = $modules{$directory} = {};

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #	
# release info
$hash->{sf_group_id}            = sf_group_id();
$hash->{sf_package_id}          = sf_package_id();

$hash->{module_name}            = $module;

$hash->{releaserc_exists}       = releaserc_exists();
$hash->{changes_exists}         = changes_exists();
$hash->{readme_exists}          = readme_exists();
$hash->{has_prereq}             = has_prereq_test();
$hash->{has_pod}                = has_pod_test();
$hash->{dist_in_cvsignore}      = dist_name_in_cvsignore( $module );
$hash->{sourceforge_note}       = sourceforge_note_in_docs( glob( "lib/*.pm" ) );
$hash->{meta_yml_in_cvsignore}  = meta_yml_in_cvsignore();
$hash->{whitespace_stripped}    = whitespace_stripped( glob( "lib/*.pm" ) );
$hash->{man13pod_exists}        = man13pod_exists();
$hash->{dist_name_in_clean}     = dist_name_in_clean( $module );
$hash->{uses_test_manifest}     = uses_test_manifest();
$hash->{manifest_skip_exists}   = manifest_skip_exists();
#$hash->{cvs_up_to_date}         = cvs_up_to_date();
$hash->{tests_have_names}       = tests_have_names();

if( $hash->{uses_test_manifest} )
	{
	$hash->{uses_test_more}         = uses_test_more( get_t_files() );
	$hash->{bail_out_in_load}       = bail_out_in_load( (get_t_files)[0] )
		|| bail_out_in_load( 'load.t' ) || bail_out_in_load( 'compile.t' );
	}
else
	{
	
	}
	
write_row( $row + 1, $hash, $worksheet );
}

ending_format( $worksheet );

$workbook->close();
#print Data::Dumper::Dumper( %modules );


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #	
BEGIN { my $column_order = [

[ qw(module_name           ), "",                        ],
[ qw(sf_group_id           ), "Sourceforge Group"        ],
[ qw(sf_package_id         ), "Sourceforge Package"      ],
[ qw(sourceforge_note      ), "Sourceforge note in docs" ],

[ qw(releaserc_exists      ), ".releaserc"               ],
[ qw(changes_exists        ), "Changes"                  ],
[ qw(readme_exists         ), "README"                   ],
[ qw(manifest_skip_exists  ), "MANIFEST.SKIP"            ],

[ qw(whitespace_stripped   ), "No trailing whitespace"   ],

[ qw(man13pod_exists       ), "Man page target exists"   ],
[ qw(dist_name_in_clean    ), "Dist name in clean"       ],

[ qw(dist_in_cvsignore     ), "Dist name in .cvsignore"  ],
[ qw(meta_yml_in_cvsignore ), "META.yml in .cvsignore"   ],

#[ qw(cvs_up_to_date        ), "CVS up-to-date"           ],

[ qw(uses_test_manifest    ), "Uses Test::Manifest"      ],
[ qw(uses_test_more        ), "Uses Test::More"          ],
[ qw(tests_have_names      ), "Tests have names"         ],
[ qw(bail_out_in_load      ), "Bail out in load"         ],
[ qw(has_prereq            ), "t/prereq.t"               ],
[ qw(has_pod               ), "t/pod.t"                  ],

];	

sub write_headers
	{
	my $worksheet = shift;
	
	my $format = $workbook->add_format(
		bg_color => 13,
		bold     => 1,
		size     => 12,
		rotation => 90,
		align    => 'center',
		);
	
	$worksheet->set_column( 0, $#$column_order, 15 );
	$worksheet->set_column( 1, $#$column_order, 7 );
	$worksheet->set_column( 3, $#$column_order, 4 );

	foreach my $column ( 1 .. $#$column_order )
		{
		$worksheet->write( 0, $column, $column_order->[ $column ][1], $format );
		}
	}
	
sub write_row
	{
	my $row  = shift;
	my $hash = shift;
	my $worksheet = shift;
	
	my @colors = map { $workbook->set_custom_color( @$_ ) }
		( [ 62, 255, 255, 255 ], [ 63, 0xAA, 0xAA, 0xAA ] );

	my $format = $workbook->add_format(
		align    => "center",
		bg_color => $colors[ $row % 2 ],
		size     => 12,
		);
	
	$worksheet->set_row( $row, 20 );

	my $url = $hash->{module_name};
	$url =~ s/::/-/g;
	$url = "http://search.cpan.org/dist/$url";
	
	my $name_format = $workbook->add_format(
		bg_color => $colors[ $row % 2 ],
		bold     => 1,
		size     => 12,
		);
	
	$Longest_name = length $hash->{module_name} 
		if length $hash->{module_name} > $Longest_name;
	
			
	$worksheet->write_url( $row, 0, $url, $hash->{module_name}, $name_format );
	
	foreach my $column ( 1 .. $#$column_order )
		{
		my $string = $hash->{ $column_order->[$column][0] } || '';
		$string = "" unless $string;
		$string = "x" if $string eq "1";
		
		$worksheet->write( $row, $column, $string, $format );
		}
	}
	
}

sub ending_format
	{
	my $worksheet = shift;
	
	warn "Longest name is $Longest_name\n";
	my $factor = 1.1;
	
	$worksheet->set_column( 0, 0, $Longest_name * $factor );
	}
	
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #	
sub releaserc_exists         { _file_exists( ".releaserc"    )                  }
sub readme_exists            { _file_exists( "README"        )                  }
sub changes_exists           { _file_exists( "Changes"       )                  }
sub manifest_skip_exists     { _file_exists( "MANIFEST.SKIP" )                  }


sub has_prereq_test          { _file_exists( "t/prereq.t" )                     }
sub has_pod_test             { _file_exists( "t/pod.t"    )                     }

sub sourceforge_note_in_docs { _match_all_files( qr/SOURCE AVAIL/, @_ )         }
sub uses_test_more           { _match_all_files( qr/Test::More/, @_ )           }

sub meta_yml_in_cvsignore    
	{ 
	_booleanize( 
		_match_in_file( qr/^META\.yml/, ".cvsignore" )
		)
	}

sub uses_test_manifest     
	{
	_booleanize(
		_match_in_file( qr/Test::Manifest/, "Makefile.PL" )
		)
	}


sub bail_out_in_load         
	{ 
	_booleanize(
		_match_in_file( qr/bail out/, @_ ) 
		)
	}

sub dist_name_in_cvsignore 
	{
	my $dist_name = shift;
	
	$dist_name  =~ s/::/-/g;
	$dist_name =~ s/-.*/-/;
	
	my $regex = qr/^\Q$dist_name/;
		
	_booleanize( _match_in_file( $regex, ".cvsignore" ) )
	}

sub manifest_has_files     
	{ 
	_booleanize( 
		_match_in_file( qr/^Meta\.yml/, 'MANIFEST' ) 
		) 
	}

sub _booleanize { $_[0] ? 1 : 0 };

sub _caller { my $c = ( caller(1) )[3]; $c =~ s/.*:://; $c }

sub sf_group_id    { _sf_field_in_releaserc( _caller ) }
sub sf_package_id  { _sf_field_in_releaserc( _caller ) }

sub _sf_field_in_releaserc
	{
	my $field = shift;
	
	my $line = _match_in_file( qr/\Q$field/, ".releaserc" );
	return unless $line;
	
	( $line =~ m/\Q$field\E\s*=?\s*(\d+)/g )[0]	
	}


sub whitespace_stripped    
	{
	local @ARGV = @_;
	while( <> ) { chomp; return if m/[ \t]$/ }
	return 1;
	}

sub prereq_is_clean        {}

sub man13pod_exists         
	{
	_booleanize( 
		_match_in_file( qr/MAN[13]POD/, "Makefile.PL" )
		)	
	}

sub dist_name_in_clean     
	{
	my $dist_name = shift;
	$dist_name  =~ s/::/-/g;
	$dist_name =~ s/-.*/-/;
	
	my $data = do { local $/; open my($fh), "Makefile.PL"; <$fh> };
	
	my( $clean ) = $data =~ m/clean\s*=>\s*{(.*?)}/sg;
	return unless ( $dist_name and $clean );
		
	return $clean =~ m/\Q$dist_name/;
	}

sub tests_have_names       
	{
	# 
	`perl Makefile.PL 2>&1`;
	
	my @lines = `make test TEST_VERBOSE=1 2>&1`;
	my $tests = grep { /^(?:not\s+)?ok\s+\d+/ } @lines;
	
	my $names = grep { /^(?:not\s+)?ok\s+\d+\s*(?:-|#\s*skip)\s*\S+/ } @lines;
	
	$tests == $names;
	}

sub release_state          {}

sub registered_module      {}

sub latest_on_sf           {}

sub latest_on_cpan           {CPAN::Module::cpan_version()}

#  CPAN::Module::inst_version()

sub cvs_up_to_date         {
	return unless -d 'CVS';
	
	print "Checking state of CVS...\n";
		
	return if grep /^[CMUA?] /, `cvs update 2>&1`;
	
	return 1;
	}

sub message          { warn @_ }
	
sub _file_exists     { -e $_[0] }

sub _match_in_file   
	{
	$_[1] or return;
	open my( $fh ), $_[1] or return;
	while( <$fh> ) { return $_ if m/$_[0]/ }
	return;
	}
	
sub _match_all_files
	{
	foreach my $file ( @_[1..$#_] )
		{
		return unless _match_in_file( $_[0], $file );
		}
	return 1;
	}
	
sub _name_to_dist { }
sub _dist_to_name { }