A Green Bar for Refactoring

The book 'Refactoring to Patterns' describes a programming tool for refactoring. One of the features of this program is that it continuously monitors the status of refactoring. When the code is broken, a status bar is red, and while it is working, the status bar is green.

Many features of a refactoring program are difficult to implement in perl, but the green bar is easy.

This program uses Tk to implement a refactoring monitor. To run the program, specify a set of files to monitor on the command line:

greenbar.pl TestGreenbar.pm t/TestGreenbar.t t/Sleep.t

Often when I am refactoring, I introduce syntax errors. These are usually easy to fix, and the red status bar seems a little extreme for this type of error. To distinguish between syntax errors and test failures, I changed the program to check syntax before running make test. If the syntax is bad, the bar shows up as pink.

When the tests are run and there are no errors, files that have been changed are checked in using RCS. This makes it easy to revert to the last version of the code that passed all the tests.

I have been having problems with the RCS checkin feature on some platforms. For now you might want to remove the call to checkin_code() and do without this feature until I fix it. It works for me on Linux but not HP-UX.

#
# Tom Anderson
# Sun Apr 24 14:15:53 PDT 2005
#
# Program to show the status of code during refactoring
#
use strict;
use warnings;
use diagnostics;
use Tk;
$|++;

our $button1;
our $test_time;

if (scalar(@ARGV)==0)
{
  usage();
  exit;
}

init_button();

sub usage
{
  print "Usage: greenbar.pl TestGreenbar.pm ".
        "t/TestGreenbar.t t/Sleep.t\n";
}

sub init_button
{
  my $mw;
  $mw= MainWindow->new;
  $mw->title( $ARGV[0] );
  $button1= $mw->Button(-background => 'orange',
                              -text => 'warming up',
                           -command => \&monitor_files
                       );
  
  $button1->pack;
  $button1->repeat(1000, \&monitor_files);
  MainLoop();
}

sub display_status
{
  my ($text, $bg)= @_;
  $button1->configure(-background => $bg, 
                      -foreground => 'black',
                      -text=> $text
                     );
  $button1->update();
  print $text,"\n";
}

sub monitor_files
{
  if ((not defined $test_time)
       or  changed_files() > 0)
  {
    $test_time= time;
    run_tests();
  }
}

sub changed_files
{
  my $found_modified = 0;
  foreach my $file (@ARGV)
  {
    my $modification_time = (stat($file))[9];
    if ((not defined $test_time) or
        $modification_time > $test_time)
    {
      $found_modified++;
    }
  }
  return $found_modified;
}

sub run_tests
{
  if (check_syntax())
  {
    make_test();
  }
}

sub check_syntax
{
  display_status('checking syntax', 'orange');
  foreach my $file (@ARGV)
  {
    my $syntax_result= `perl -c $file 2>&1`;
    if ($syntax_result !~ /syntax OK/)
    {
      display_status('failed syntax', 'pink');
      print "  in file $file\n";
      return undef;
    }
  }
  display_status('syntax OK', 'yellow');
  return 1;
}

sub make_test
{
  my $result= `make test`;
  if ($result =~ /All tests successful/)
  {
    display_status('passed', 'green');
    checkin_code();
  }
  else
  {
    display_status('failed', 'red');
  }
}

sub checkin_code
{
  foreach my $fn (@ARGV)
  {
    my $diff= `rcsdiff $fn`;
    if ($diff ne '')
    {
      print "Checking in $fn\n";
      `ci -l -m'Passed tests.' $fn`;
    }
  }
}

04/25/2005