#! /usr/local/bin/perl -w
# NOTES:
# Invariants and pre- and post-conditions are expected
# to return undef if they fail.
#
# Pre- and post-conditions receive the same argument list
# as the implementation itself. Methods and constructors
# may have as many pre- and post-conditions as they
# require.
#
# Pre- and post-conditions and invariants may be declared
# optional. Optional conditions may be switched on and off
# using the &check method (see examples below).
#
# The subroutine &self always returns a reference to
# the invoking object. However, that reference is still
# also passed as the first argument.
#
# The implementation's return value is available in the
# method's post-condition(s) through the subroutine
# &value, which returns a reference to a scalar or an array
# (depending on the calling context).
#
# &value also provides access to the value of an attribute within
# that attribute's pre- and post-conditions.
#
# The value of the object prior to a method is available in the
# post-conditions via the &old subroutine, which returns a copy
# of the object as it was prior to the method call.
#
# Methods can be declared abstract. They croak if not redefined.
#
# Class methods and attributes can be declared.
#
# The constructor implementation is invoked *after* the object
# is created and blessed into the class. It only needs to
# initialize the object returned by &self. Its return value is ignored.
#
# The implementations of all base class constructors are called
# automatically by the derived class constructor (and passed
# the same argument list)
#
# Attributes are private to the class in which they're declared.
# Attributes cannot be accessed directly, only via their
# accessor methods. This is true even within class methods.
# All generated accessors return a reference to their attribute.
#
# Accessors may only have preconditions.
#
# Accessors and methods inherit (all) the preconditions of
# every ancestral accessor or method of the same name.
#
package QueueBase;
use Class::Contract 'old';
contract {
abstract method 'append';
abstract method 'next';
ctor 'new';
impl { print "QueueBase::new!\n" };
};
package ClientQueue;
use Class::Contract 'old';
contract {
inherits QueueBase;
invar { print "appends: ", self->flags->{append} || 0, "\n"; };
invar { print "nexts: ", self->flags->{next} || 0, "\n"; };
optional invar {
@{self->queue} > 0 || undef;
}; failmsg "Empty queue detected at %s after call";
attr queue => ARRAY;
attr flags => HASH;
class attr 'first';
method 'append';
optional pre { print "first append\n" if ${self->first}; 1; };
pre {
print "<<<0>>>\n";
return 0 unless shift(@_)->isa("Client");
print "<<<0.1>>>\n";
1;
}; failmsg "Expected Client object";
post {
return unless @{self->queue} == @{old->queue} + 1;
return unless self->queue->[-1]{id} == $_[0]{id};
return 1;
};
impl {
print "<<<1>>>\n";
${self->first} = 0;
print "<<<2>>>\n";
self()->flags->{append}++;
print "<<<3>>>\n";
push @{self->queue}, shift;
print "<<<4>>>\n";
};
method 'next';
post {
return unless @{self->queue} == @{old->queue} - 1;
return 1;
}; failmsg "Expected removal of a single Client object";
impl {
self->flags->{next}++;
shift @{self->queue}
};
ctor 'new';
pre {
return unless @_ >= 1 && !grep {!$_->isa('Client')} @_;
return 1;
}; failmsg "constructor must be passed an initial Client obj";
impl {
@{self->queue} = ( shift );
${self->first} = 1;
};
};
package OrderedQueue;
use Class::Contract 'old';
contract
{
inherits 'ClientQueue';
method 'append';
post {
return unless $_[0]{id} > self->queue->[-2]{id};
}; failmsg "Client appended out of order";
ctor 'new';
impl { print "OrderedQueue::new!\n" };
};
package Client;
my $nextid = 1;
sub new {
bless { id => $nextid++ }, ref($_[0]) || $_[0];
}
package Main;
use Class::Contract qw(check);
check my %contract => 0 for (__ALL__); # TURN OFF ALL OPTIONAL CHECKS
check %contract for ('ClientQueue'); # TURN ON OPTIONAL CHECKS
# FOR ClientQueue ONLY
print "[[[1]]]\n";
my $client = Client->new();
print "[[[2]]]\n";
my $order_queue = OrderedQueue->new($client);
$client = Client->new();
print "[[[3]]]\n";
$order_queue->append($client);
print "[[[4]]]\n";
$client = Client->new();
my $client2 = Client->new();
print "[[[5]]]\n";
# Uncomment following to get append out of order error
# $order_queue->append($client2);
$order_queue->append($client);
print "[[[6]]]\n";
$client = "not a client";
# Expected Client object
eval '$order_queue->append($client)';
print $@ if $@;
print $order_queue->next(), "\n";
print $order_queue->next(), "\n";
print $order_queue->next(), "\n";
# Nothing left in queue: Expected removal a single Client object
my $val = $order_queue->next();
print "$val\n";
1;