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 = '0.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); } croak "Missing 'ensure' block for step" unless exists $self->{ensure_block}; croak "Missing 'using' block for step" unless exists $self->{using_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__ =head1 NAME Commands::Guarded - Better scripts through guarded commands =head1 SYNOPSIS use Commands::Guarded; my $var = 0; step something => ensure { $var == 1 } using { $var = 1 } ; # $var is now 1 step nothing => ensure { $var == 1 } using { $var = 2 } # bug! ; # $var is still 1 (good thing too) my $brokeUnless5 = step brokenUnless5 => ensure { $var == 5 } using { $var = shift } ; # nothing happens yet print "var: $var\n"; # prints 1 $brokeUnless5->do(5); print "now var: $var\n"; # prints 5 step fail => ensure { $var == 3 } using { $var = 2 } ; # Exception thrown here =head1 DESCRIPTION This module implements a deterministic, rectifying variant on Dijkstra's guarded commands. Each named step is passed two blocks: an C block that defines a test for a necessary and sufficient condition of the step, and a C block that will cause that condition to obtain. If C is called in void context (i.e., is not assigned to anything or used as a value), the step is run immediately, as in this pseudocode: unless (ENSURE) { USING; die unless ENSURE; } If C is called in scalar or array context, execution is deferred and instead a Commands::Guarded object is returned, which can be executed as above using the C method. If C is given arguments, they will be passed to the C block and (if necessary) the C block. The interface to Commands::Guarded is thus a hybrid of exported subroutines (see B below) and non-exported methods (see B). For a detailed discussion of the reason for this module's existence, see B below. =head1 SUBROUTINES =over =item step NAME => EXPR... Defines a new guarded command step. If called in void context, the step is executed immediately. If called in scalar or array context (i.e., in an expression or assignment), a Commands::Guarded object is returned (see B below). NAME is a string that will be printed on failure (also see C below). EXPR is one or more Commands::Guarded blocks (see B below). Typically at least a C and C block will be included. Note that because C is a subroutine and not a control structure (though it acts like one in void context), it typically must be followed by a semicolon. It's recommended therefore to use the style step name => ensure { ... } using { ... } ; so as not to forget it. =item verbose SCALAR (Not exported by default.) If true, will print output not only on failure of a step, but also at the beginning of a step (i.e., after the C block is first run) indicating whether the condition failed ("Doing I") or succeeded ("Skipping I"). Also prints a message ("Step I succeeded") if the C condition now obtains after running C. Whether or not C is set, an exception will be thrown if the condition fails to obtain after running C, with the message "Step I failed at line...". Besides using this subroutine, the environment variable I can also be used to control this behavior without modifying the code. I will set the I behavior of C; when set to a true value, the script will run as if a C were specified at the beginning. (A C will always disable verbosity, no matter the value of I.) =item clear_rollbacks (Not exported by default.) Clears rollbacks. See C in the section B below. =back =head1 BLOCKS =over =item ensure BLOCK Defines a test for the step. Should return true if the condition of the test has been met, false otherwise. It's common to write ensure blocks as a chain of boolean expressions: ensure { -d "$ENV{HOME}" and fgrep qr/^$userid:/, '/etc/passwd' } but it is also possible to use C for more complicated tests: ensure { foreach my $dir (@dirs) { return 0 unless -d $dir; } return 1 } A true return from C will cause the script to continue execution. A false return can have two possible effects: it will run the step's C block, or, if the C block has already been run, it will throw an exception. =item using BLOCK Defines the code to affect the condition in C. If the containing step's C block returns a false value, BLOCK will be run. =item sanity BLOCK Defines a sanity check for a step. Like C, BLOCK should define a condition. The condition is checked at the beginning of the enclosing step (prior to C), and again after running the C block (if the C block is run, of course). If it returns a false value, an exception is thrown with the message "Sanity check for I failed". Note given this behavior that a sanity check should specify an I condition, i.e. something you expect to be true whether or not the step has run with success or failure. For example: step removeScratch => ensure { not fgrep qr|^\S*\s+/scratch|, '/etc/fstab' } using { ... } sanity { # Don't lose boot partition! fgrep qr|^\S*\s+/boot\s|, '/etc/fstab' } ; =item rollback BLOCK Defines a rollback action for the step. If this step, I, fails (either through C verification or C check failure), the rollback will be run. If multiple rollbacks are defined, they will be run in LIFO (Last-In, First-Out) order. B: if an exception (C or C) is thrown in your rollback, the script will stop and other rollbacks will not be called. If you truly intend to abort all previously set rollbacks, you should use C. You can (and probably should in most cases) call C itself from within a C block: step clearRollbacks => ensure { ... } using { ... } rollback { clear_rollbacks; ... } ; =back =head1 METHODS =over =item ->do =item ->do ARGS Executes a step, possibly with arguments. If arguments are supplied, they will be passed to every block within the step. Note that the arguments are read-only within the block (i.e., attempting to modify an element of @_ will throw an exception), though you can use C, etc. Some attempt is made to deal with return values, so you can get something approximating a reasonable result from C when the C block has executed. But the author has not found a real-world need for return values, so their behavior is not very well-defined. (Feel free to contact him if you believe you have a solution.) =item ->do_foreach LIST For each item of LIST, check C, passing the item as an argument. After all Cs have been run, run C with those arguments whose C failed. Return values are not supported. At present, multiple arguments for each call are not supported, either (though you can certainly simulate that using a list-of-lists, if you write your blocks to take an arrayref). =back =head1 UTILITY SUBROUTINES These subroutines have nothing directly to do with the module, but they are so useful in conjunction with them, they have been included. =over =item fgrep REGEX, SCALAR Returns true if REGEX is found on any line of the file referenced by SCALAR. SCALAR can be a filehandle variable (not a bare filehandle) or a string, in which case it is opened. For instance: die "Load too high" unless fgrep qr/averages: 0[.]/, '/usr/bin/uptime|'; Will throw an exception if the file cannot be opened for reading. =item readf FILENAME Returns a filehandle opened on FILENAME for reading. Will throw an exception if the file cannot be opened for reading. =item writef FILENAME Returns a filehandle opened on FILENAME for writing. Will throw an exception if the file cannot be opened for writing. =item appendf Returns a filehandle opened on FILENAME for appending. Will throw an exception if the file cannot be opened for appending. =back =head1 RATIONALE People often intuitively refer to some sorts of executables as "scripts" and others as "programs." When pressed for a definition, they will often fall back on language-specific criteria (such as whether the program is compiled or interpreted) that really do not capture the essence of the difference between scripting and more general-purpose programming. A I