[FWP] Using invariants in OO modules.

[abigail@foad.org]

For lovers of bondage style OO-programming.
(The POD is at the end)

Comments welcome.

Abigail




package Invariant;

use strict;
use Exporter;

use vars  qw /@ISA @EXPORT $VERSION/;

@ISA     = qw /Exporter/;
@EXPORT  = qw /invariant variant/;

$VERSION = '0.01';

my %invariants;
my %options = map {$_ => 1} qw /constructor ignore include/;
my %ignore  = map {$_ => 1} @EXPORT;


sub import {
    my $me     = shift;
    my $caller = caller;

    $invariants {$caller} ||= {};
    while (@_ > 1) {
        my ($option, $value) = splice @_ => 0, 2;
        if ($options {$option}) {
            my @values;
            if (ref $value) {
                die "Cannot take a " . ref $value . " reference as value " .
                    "to 'use Invariant $option'.\n"
                    unless "ARRAY" eq ref $value;
                @values = @$value;
            }
            else {
                @values = ($value);
            }
            foreach my $value (@values) {
                $invariants {$caller} -> {info} -> {$value} -> {$option} = 1;
            }
            next;
        }
        die "Unknown option $option to 'use Invariant'.\n";

    }
    die "Uneven number of arguments to 'use Invariant'.\n" if @_;

    Invariant -> export_to_level (1, $me => @EXPORT);

}

sub fix_subs {
    my $caller = shift;

    no strict 'refs';
    foreach my $glob (keys %{"${caller}::"}) {
        next if $ignore {$glob};
        my $info = $invariants {$caller} -> {info} -> {$glob};
        next if $info -> {ignore};
        next if ("_" eq substr $glob => 0, 1 or
                 $glob eq uc $glob and $glob ne "AUTOLOAD") and
                !$info -> {include};
        my $name = "${caller}::$glob";
        if (defined &$name) {
            my $coderef = *{$name}{CODE};  # Memoize was here.
            no warnings 'redefine';
            *$name = sub {
                my $self = $_ [0];
                my (@results, $result);
                if (wantarray) {
                    @results = $coderef -> (@_);
                }
                elsif (defined wantarray || $info -> {constructor}) {
                    $result  = $coderef -> (@_);
                }
                else {
                    $coderef -> (@_);
                }

                while (my ($name, $invariant) =
                          each %{$invariants {$caller} -> {invariants}}) {
                    local $_;
                    if ($info -> {constructor}) {
                        $_ = wantarray ? $results [0] : $result;
                    }
                    else {
                        $_ = $self;
                    }
                    $invariant -> ($_) or die
                        "Invariant `$name' in package $caller " .
                        "violated when exiting sub $glob.\n";
                }

                wantarray ? @results : $result;
            }
        }
    }
}


INIT {
    foreach my $caller (keys %invariants) {
        fix_subs $caller;
    }
}

sub invariant (&;$) {
    my  $caller = caller;
    my ($invariant, $name) = @_;

    unless (defined $name) {
        $name = "inv_${caller}";
        if ($invariants {$caller} -> {invariants}) {
            $name .= "_" . (1 + keys %{$invariants {$caller} -> {invariants}});
        }
    }

    $invariants {$caller} -> {invariants} -> {$name} = $invariant;
}

sub variant ($) {
    my $caller = caller;
    my $name   = shift;

    delete $invariants {$caller} -> {invariants} -> {$name};
}


1;

__END__

=pod

=head1 NAME

Invariant -- Provide invariants for OO modules.

=head1 SYNOPSIS

    use Invariant constructor => 'new';

    invariant {$_ -> {current} >= $_ -> {min} &&
               $_ -> {current} <= $_ -> {max}};

    sub new {my ($pkg, $min, $max) = @_;
             bless {current => $min, min => $min, max => $max} => $pkg}
                                # This will die if $min > $max.

    sub current {
        my $self = shift;
        if (@_) {
            $self -> {current} = $_ [0];
        }
        $self -> {current}      # dies if $self -> {current} is set to
    }                           # less then $self -> {min} or more than
                                # $self -> {max}.


=head1 DESCRIPTION

This module provides a convenient way to install I<invariants>. An
invariant is an expression that is true at sequence points - in this case,
when exiting OO methods.

The invariant is given as a code reference, and when called, it is passed
the I<current> object (in both C<$_> and C<$_ [0]>). The current object is
normally the object on which the method was invoked, but for constructors,
it is the return value of the constructors.

The C<Invariant> module divides the subroutines of a class into three
categories: I<methods>, I<constructors>, and I<other subs>. Invariants
are checked when exiting methods and constructors, but not when running
other subs.  By default, C<Invariant> regards all subroutines of a
class to be a method, unless the name of the subroutine starts with an
underscore, or when the name of the subroutine is in all uppercase (but
with the exception of C<AUTOLOAD>). In both cases, such subroutines are
considered in the class of other subs, and no invariant will be checked.

C<use Invariant> takes a list arguments, a sequence of option/value pairs,
where option is one of C<constructor>, C<ignore> or C<include>. Each
value is either a name of a subroutine, or a reference to an array of
names of subroutines.

A subroutine that is marked C<constructor> is assumed to return a new
object, and this return value is passed to the invariants to check,
as opposed to normal methods which have their first argument passed. A
subroutine that is marked C<ignore> will not have an invariant checked
on exiting - this is useful for non-OO subroutines, or perhaps class
methods (but you can use invariants for class methods as well). The
category C<include> is useful for methods that would normally be excluded
(because they start with an underscore, or are in full caps) from checking
invariants, but for which you want to check the invariants anyway.

C<use Invariant> exports (unconditionally) two subroutines to the current
package: C<invariant> and C<variant>.

C<invariant> takes one or two arguments. The first argument is a code
reference. The code reference is considered the invariant. Before running,
the current object is set to C<$_> and C<$_ [0]>. The invariant should
return a true value. If a false value is returned the program will C<die>
with a message saying which invariant failed, in which package that
happened, and what the subroutine is that violated the invariant.
Alternatively, the invariant may C<die> itself. 

The second, optional, argument of C<invariant> is the name of the invariant.
If no name is given, a name will be constructed by taking the class name,
prefixing it with C<inv_>, and from the second invariant onwards, using
a suffix with a sequence number.

The subroutine C<variant> takes a single argument, a name of an invariant.
That invariant is removed from the list of invariants to check.

=head1 CAVEATS

=over 2

=item *

C<Invariant> does it way by installing wrappers around subroutines. This
is done when the C<INIT> section of C<Invariant> is run. Only subroutines
defined in the package using C<Invariant> at that time are considered;
methods that are installed afterwards (for instance, from C<AUTOLOAD>,
will not have invariants checked).

=item *

The behaviour of putting a method in more than one I<constructor>,
I<ignore> or I<include> category is determined by the tea leaves in
my next cuppa.

=item *

Because this module does it work by installing wrappers around methods,
the call stack will contain one more entry.

=item *

Be careful when using C<goto &othersub>.

=item *

C<invariant> takes a coderef as first argument. This can be given as a
I<block>, that is, without the leading C<sub> keyword. If done so, and
given a second argument (the name of the invariant), there should B<not>
be a space between the block and the name.

=back

=head1 TODO

=over 2

=item *

If an invariant fails, we should die throwing an object with information,
instead of just a string. But it should give a similar message as we do
now when the object is stringified.

=item *

We need to keep track of how many invariants have been installed in total.
Currently, if you now install 2 invariants, deinstall the first, then install
a third, and you don't set names yourself for the second and third, the third
invariant will remove the second.

=item *

Get rid of using Exporter.

=item *

Currently, C<invariant> and C<variant> are installed unconditionally.
Find a way to make this optional, without too much of a hack.

=item *

Lots more testing.

=item *

h2xs and making it CPANnable.

=back

=head1 REVISION HISTORY

    $Log: $

=head1 AUTHOR

This package was written by Abigail, abigail@foad.org.

=head1 COPYRIGHT and LICENSE

This program is copyright 2000 by Abigail.

Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
 
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

=cut

==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe