File Coverage

blib/lib/Commands/Guarded.pm

Criterion	Covered	Total	%
statement	95	111	85.5
branch	25	40	62.5
condition	1	3	33.3
subroutine	22	27	81.4
pod	9	11	81.8
total	152	192	79.1

package Commands::Guarded;

use 5.006;
use strict;
use warnings;
use Carp;
use IO::File;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
		    utils => [ qw(
				  fgrep
				  readf
				  appendf
				  writef
				 ) ],
		    step => [qw(
				step
				ensure
				using
				sanity
				rollback
			       )],
		    other => [qw(
				 verbose
				 clear_rollbacks
				)]
		   );

$EXPORT_TAGS{default} = $EXPORT_TAGS{step};

foreach (keys %EXPORT_TAGS) {
   push @{$EXPORT_TAGS{'all'}}, @{$EXPORT_TAGS{$_}}
}

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} });

our @EXPORT = ( @{ $EXPORT_TAGS{'default'}} );

our $VERSION = '1.01';

# A constructor that's exported (horrors!) -- everything starts here

sub step ( $@ ) {
   my $step = __PACKAGE__->new(@_);
   unless (defined wantarray) {
      $step->do();
      return;
   }
   return $step;
}

# Define blocks

my @defined_blocks = qw(
			ensure
			using
			sanity
			rollback
		       );

# Create an exportable subroutine called BLOCK_block for each name above
# that blesses the block passed as the appropriate class.  Autocreate
# the class and make it a subclass of Commands::Guarded::Block.

foreach my $block (@defined_blocks) {
   my $block_block = "$block" . "_block";
   my $class = "Commands::Guarded::Block::$block_block";
   no strict 'refs';
   @{"${class}::ISA"} = qw(Commands::Guarded::Block);
   # install the exportable sub
   *$block = sub ( &;@ ) {
      my ($block, @rest) = @_;
      $block = bless $block, $class;
      return ($block, @rest);
   };
   # install the accessor method
   *$block_block = sub { $_[0]->{$block_block} };
}

# The only method for this class, so we just install it here rather than creating
# a separate package file

sub Commands::Guarded::Block::add {
   # Add block to enclosing step
   my $self = shift;
   my ($type) = (ref($self) =~ /.*::(.*)/);
   my $step = shift;
   $step->{$type} = $self;
}

# Verbosity on (or off); defaults to env variable or 0
my $verbose = exists $ENV{GUARDED_VERBOSE} ? $ENV{GUARDED_VERBOSE} : 0;
sub verbose (;$) {
   if (@_) {
      $verbose = shift;
   }
   $verbose;
}

sub new {
   my $class = shift;
   $class = ref($class) || $class;
   my ($name, @blocks) = @_;
   my $self = bless {
		     name => $name,
		    }, $class;
   foreach my $block (@blocks) {
      $block->add($self);
   }
   if (not exists $self->{using_block}) {
       $self->{using_block} = sub { 1 };
   }
   croak "Missing 'ensure' block for step"
       unless exists $self->{ensure_block};
   return $self;
}

sub _diag ( @ ) {
   print STDERR @_ if verbose;
}

# Rollback handlers

our @rollbacks;

sub _register_rollback {
   my $self = shift;
   if (defined $self->rollback_block) {
      push @rollbacks, [$self->rollback_block => \@_];
   }
}

sub clear_rollbacks {
   @rollbacks = ();
}

sub _do_rollbacks () {
   while (@rollbacks) {
      my $rollback = pop @rollbacks;
      my $sub = $rollback->[0];
      my @args = @{$rollback->[1]};
      $sub->(@args);
   }
}

sub _fail ( @ ) {
   _do_rollbacks;
   croak @_;
}


# The only accessor not dynamically created

sub name {
   my $self = shift;
   my $name = $self->{name};
   if (@_) {
      $name .= "(@_)";
   }
   $name;
}

sub _check_sanity {
   my $self = shift;
   if (defined $self->sanity_block) {
      $self->sanity_block->(@_)
	or _fail "Sanity check for " . $self->name(@_) . " failed";
   }
}

sub _do_pre_using {
   my $self = shift;
   $self->_check_sanity(@_);
   $self->_register_rollback(@_);
   return $self->ensure_block->(@_);
}

sub do {
   my $self = shift;
   unless ($self->_do_pre_using(@_)) {
      _diag "Doing step " . $self->name(@_) . "\n";
      my @returns;
      # Preserve calling context in case we're being used for return value
      # (But why would anyone want to do that?)
      if (wantarray) {
	 @returns = $self->using_block->(@_);
      } elsif (defined wantarray) {
	 $returns[0] = $self->using_block->(@_);
      } else {
	 $self->using_block->(@_);
      }
      $self->_check_sanity(@_);
      if ($self->ensure_block->(@_)) {
	 _diag "Step " . $self->name(@_) . " succeeded\n";
	 return @returns;
      }
      _fail "Step " . $self->name(@_) . " failed";
   }
   _diag "Skipping step " . $self->name . "\n";
   return;
}

sub do_foreach {
   my $self = shift;
   my @usings;
   foreach my $arg (@_) {
      unless ($self->_do_pre_using($arg)) {
	 push @usings, $arg;
      } else {
	 _diag "Skipping step " . $self->name($arg) . "\n";
      }
   }
   foreach my $arg (@usings) {
      _diag "Doing step " . $self->name($arg) . "\n";
      $self->using_block->($arg);
      $self->_check_sanity($arg);
      if ($self->ensure_block->($arg)) {
	 _diag "Step " . $self->name($arg) . " succeeded\n";
      } else {
	 _fail "Step " . $self->name . " failed";
      }
   }
   return;
}

# Useful utilities

sub readf ( $ ) {
   my $fh = new IO::File $_[0]
     or die "Can't open $_[0] for reading: $!\n";
   $fh;
}

sub writef ( $ ) {
   my $fh = new IO::File ">$_[0]"
     or die "Can't open $_[0] for writing: $!\n";
   $fh;
}

sub appendf ( $ ) {
   my $fh = new IO::File ">>$_[0]"
     or die "Can't open $_[0] for appending: $!\n";
   $fh;
}

sub fgrep ( $$ ) {
   my ($re, $fh) = @_;
   unless (ref $fh) {
      $fh = readf $fh;
   }
   while (<$fh>) {
      return 1 if /$re/;
   }
   return 0;
}

1;
__END__