File Coverage

blib/lib/Class/Contract.pm

Criterion	Covered	Total	%
statement	343	565	60.7
branch	137	292	46.9
condition	49	108	45.3
subroutine	57	108	52.7
pod	3	30	10.0
total	589	1103	53.4

package Class::Contract;
use strict;
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
require Exporter;
use Carp;

$VERSION = '1.14';

@ISA = qw(Exporter);
@EXPORT = qw(contract ctor dtor attr method pre impl post invar inherits
             self value class abstract private optional check callstate
             failmsg clon);
@EXPORT_OK = qw(scalar_attrs array_attrs hash_attrs methods old);
%EXPORT_TAGS = (DEFAULT  => \@EXPORT,
                EXTENDED => \@EXPORT_OK,
                ALL      => [@EXPORT, @EXPORT_OK]);

my %contract;
my %data;
my %class_attr;
my $current;
my $msg_target;
my %no_opt;    # NOT IN PRODUCTION
# $Class::Contract::hook = \%data; # for testing GC # NOT IN PRODUCTION

my @class_dtors;
END { $_->()  foreach (@class_dtors) }

my ($carp, $croak) = (
  sub {
    my (@c) = caller(0);
    ($c[3] eq 'Class::Contract::__ANON__')
      ? print STDERR (@_, " at $c[1] line $c[2]\n") : &carp
  },
  sub {
    my (@c) = caller(0);
    ($c[3] eq 'Class::Contract::__ANON__')
      ? die(@_, " at $c[1] line $c[2]\n") : &croak
  }
);

sub import {
  my $class = $_[0];
  my $caller = caller;
  $contract{$caller}{use_old} = grep(/^old$/, @_) ? 1 : 0;
  push @_, @EXPORT;
  no strict 'refs';
  INIT {
    *{$caller .'::croak'} = $croak  if defined *{$caller .'::croak'}{'CODE'};
    *{$caller .'::carp'}  = $carp   if defined *{$caller .'::carp'}{'CODE'};
  }
  goto &Exporter::import;
}

sub unimport {
  my $class = shift;
  my $caller = caller;
  $contract{$caller}{use_old} = 0  if grep /^old$/, @_;
}

sub contract(&) {  $_[0]->();  _build_class(caller) }

sub check(\%;$) {
# NOT IN PRODUCTION...
  my $state = !$#_ ? 0 : $_[1] ? 1 : 0;
  defined $_
    or croak("Usage:\n\tcheck \%sentinel",
       ($#_ ? " => $state" : ""),
       " for ( \@classes );\n\n");

  my $forclass = $_;
  $_[0]->{$forclass} =
    bless { 'prev'     => $no_opt{$forclass},
      'forclass' => $forclass }, 'Class::Contract::FormerState';
  $no_opt{$forclass} = $state;
# ...NOT IN PRODUCTION
}

# NOT IN PRODUCTION...
sub Class::Contract::FormerState { # No function signature?
  $no_opt{$_[0]->{'forclass'}} = $_[0]->{'prev'}; #  my ($self) = @_;
}

sub no_opt { # my ($class) = @_;
  return   exists $no_opt{$_[0]}     ? $no_opt{$_[0]}
         : exists $no_opt{'__ALL__'} ? $no_opt{'__ALL__'}
         : 0;
}
# ...NOT IN PRODUCTION

sub _location { # scalar context returns file and line of external code
                # array context returns package aka 'owner', file and line
  my ($i, @c, $owner);
  while (@c = (caller($i++))[0..2]) {
    if ($c[0] !~ /^Class::Contract$/) {
      $owner = $c[0]  if !$owner;
      if ($c[1] !~ /^\(eval \d+\)$/) {
        return (wantarray ? $owner : (), join ' line ', @c[1,2]);
      }
    }
  }
}

my %def_type = (
  'attr'   => 'SCALAR',
  'method' => '',
  'ctor'   => '',
  'dtor'   => '',
  'clon'   => '',
);

sub _member {
  my ($kind, $name, $type) = @_;
  my ($owner, $location) = _location;
  $name = ''  unless $name;

  if (defined $contract{$owner}{$kind}{$name}) {
    croak "\u$kind ${owner}::$name redefined"  if $name;
    croak "Unnamed $kind redefined";
  }

  $contract{$owner}{$kind}{$name} = $current =
    bless {'name'     => $name,
           'type'     => $type || $def_type{$kind},
           'gentype'  => $type || $def_type{$kind},  # NOT IN PRODUCTION
           'loc'      => $location,
           'shared'   => 0,
           'private'  => 0,
           'abstract' => 0,
           'pre'      => [], # NOT IN PRODUCTION
           'post'     => [], # NOT IN PRODUCTION
          }, "Class::Contract::$kind";

  # NOT IN PRODUCTION...
  $current->{'gentype'} = 'OBJECT'
    unless $current->{'gentype'} =~ /\A(SCALAR|ARRAY|HASH)\z/;
  # ...NOT IN PRODUCTION
  return $current;
}

sub attr($;$) { _member('attr'   => @_) }
sub method($) { _member('method' => @_) }
sub ctor(;$)  { _member('ctor'   => @_) }
sub dtor()    { _member('dtor') }
sub clon()    { _member('clone') }

sub scalar_attrs(@) { map _member('attr', $_, 'SCALAR'), @_ }
sub array_attrs(@)  { map _member('attr', $_, 'ARRAY'),  @_ }
sub hash_attrs(@)   { map _member('attr', $_, 'HASH'),   @_ }
sub methods(@)      { map _member('attr', $_),           @_ }

sub class(@)    { $_->{'shared'}   = 1  foreach(@_); @_ }
sub abstract(@) { $_->{'abstract'} = 1  foreach(@_); @_ }
sub private(@)  { $_->{'private'}  = 1  foreach(@_); @_ }

my %def_msg = (
  'pre'   => 'Pre-condition at %s failed',
  'post'  => 'Post-condition at %s failed',
  'invar' => 'Class invariant at %s failed',
  'impl'  => undef
);

sub _current {
  my ($field, $code) = @_;
  croak "Unattached $field"  unless defined $current;
  croak "Attribute cannot have implementation"
    if $current->isa('Class::Contract::attr') && $field eq 'impl';

  my $descriptor = bless {
    'code'  => $code,
    'opt'   => 0,    # NOT IN PRODUCTION
    'msg'   => $def_msg{$field},
  }, 'Class::Contract::current';
  @{$descriptor}{qw(owner loc)} = _location;

  if ($field eq 'impl' && !( $current->isa('Class::Contract::ctor')
                          || $current->isa('Class::Contract::dtor')
                          || $current->isa('Class::Contract::clone') )) {
    $current->{$field} = $descriptor
  } else {
    push @{$current->{$field}}, $descriptor
  }

  $msg_target = $descriptor;
}

sub failmsg {
  croak "Unattached failmsg"  unless $msg_target;
  $msg_target->{'msg'} = shift;
}

sub pre(&)  { _current('pre'  => @_) }
sub post(&) { _current('post' => @_) }
sub impl(&) { _current('impl' => @_) }

sub optional { # my (@descriptors) = @_;
  $_->{'opt'} = 1  foreach(@_); @_ # NOT IN PRODUCTION
}

sub invar(&) {
  my ($code) = @_;

  my $descriptor = {
    'code'  => $code,
    'opt'   => 0,    # NOT IN PRODUCTION
    'msg'   => $def_msg{'invar'},
  };
  @{$descriptor}{qw(owner loc)} = _location;

  push @{$contract{$descriptor->{'owner'}}{'invar'}}, $descriptor;
  $msg_target = $descriptor;
}


sub inherits(@)  {
  my ($owner) = _location;
  foreach (@_) {
    croak "Can't create circular reference in inheritence\n$_ is a(n) $owner"
      if $_->isa($owner)
  }
  push @{$contract{$owner}{'parents'}}, @_;
}

sub _build_class($) {
  my ($class) = @_;
  my $spec = $contract{$class};
  _inheritance($class, $spec);
  _attributes($class, $spec);
  _methods($class, $spec);
  _constructors($class, $spec);
  _destructors($class, $spec);
  _clones($class, $spec);
  1;
}

localscope: {
  my @context;
  my %clear; # NOT IN PRODUCTION;
  sub _set_context  {
    push @context, {'__SELF__' => shift};

    # NOT IN PRODUCTION...
    my $proto = $context[-1]{__SELF__};
    my ($class, $obj) = ref($proto)
      ? (ref($proto), $proto)
      : ($proto, undef);
    return  if $class =~ /^Class::Contract::Old::_/;

    if ($contract{$class}{'use_old'}) {
      my $class_old = "Class::Contract::Old::_$#context";
      _pkg_copy($class, $class_old);
      my $old = $class_old;
      if ($obj) {
        # Like generic_clone but into the cloned class
        my $old_key = \ my $undef;
        $old = bless \ $old_key, $class_old;
        $data{$$old} = _dcopy($data{$$obj})  if exists $data{$$obj};
      }
      $context[-1]{__OLD__} = $old;
    }
    # ...NOT IN PRODUCTION
  }
  sub _free_context {
    return pop @context
  }
  sub old() {
    croak "No context. Can't call &old"  unless @context;
    my $self = $context[-1]{__SELF__};
    my $class = ref($self) || $self;
    croak "Support for &old has been toggled off"
      unless ($contract{$class}{'use_old'});
    $context[-1]{__OLD__} # NOT IN PRODUCTION
  }

  my @value;
  sub _set_value  { push @value, \@_ }
  sub _free_value { my $v = pop @value; wantarray ? @$v : $v->[0] }

  sub value {
    croak "Can't call &value "  unless @value;
    return $value[-1];
  }

  sub self() {
    if (@_) {
      # NOT IN PRODUCTION...
      croak "Usage:\tself(\$class_or_object)"
        unless defined *{join(ref($_[0])||$_[0], '::')};
      # ...NOT IN PRODUCTION
      $context[-1]{__SELF__} = shift;
    }
    croak "No context. Can't call &self"  unless @context;
    $context[-1]{__SELF__}
  }

  sub callstate() {
    croak "No context. Can't call &callstate"  unless @context;
    return $context[-1];
  }
}

sub _inheritance {                                  #  A  D  Invokation order
# Inheritence is left-most depth-first. Destructors #  /\ |
# are called in reversed order as the constructors  # B C E    ctor: ABCDEF
# Diamond patterns in inheritence are 'handled' by  #  \//     dtor: FEDCBA
# looking for and skipping duplicate anonymous refs #   F

  my ($classname, $spec) = @_;
  my (%inherited_clause, %inherited_impl);
  foreach my $ancestor ( reverse @{$spec->{'parents'} || [] } ) {
    my $parent = $contract{$ancestor} || next;
    if ($parent->{'use_old'} and not $spec->{'use_old'}) {
      croak("Derived class $classname, has not toggled on support for ->old\n",
            "which is required by ancestor $ancestor. Did you forget to\n",
            "declare: use Class::Contract 'old'; ?");
    }
    foreach my $clause ( qw( attr method ctor clone dtor ) ) {
      foreach my $name ( keys %{ $parent->{$clause} || {} } ) {
        # Inherit each clause from ancestor unless defined
        if (! defined $spec->{$clause}{$name}
            and not exists $inherited_clause{$name}) {
          $inherited_clause{$name}++;
          %{$spec->{$clause}{$name}} = (%{$parent->{$clause}{$name}});
          $spec->{$clause}{$name}{'pre'}  = []; # NOT IN PRODUCTION
          next;
        }

        # Inherit ctor/clone/dtor invokation from ancestors
        if ($clause =~ /^(ctor|clone|dtor)$/) {
          if (defined $parent->{$clause}{$name}{'impl'}
              and @{$parent->{$clause}{$name}{'impl'}}) {
            my (@impl, %seen) = (@{$spec->{$clause}{$name}{'impl'}});
            if (@impl) {
              $seen{$impl[$_]} = $_  foreach (0..$#impl);
              foreach my $item ( @{$parent->{$clause}{$name}{'impl'}} ) {
                splice(@{$spec->{$clause}{$name}{'impl'}}, $seen{$item}, 1)
                   if exists $seen{$item};
              }
            }
            $clause ne 'dtor'
            ? unshift(@{$spec->{$clause}{$name}{'impl'}},
                      @{$parent->{$clause}{$name}{'impl'}})
            : push(@{$spec->{$clause}{$name}{'impl'}},
                   @{$parent->{$clause}{$name}{'impl'}});
          }
        }

        # Get implementation from ancestor if derived but not redefined
        if ($clause eq 'method') {
          if (! defined $spec->{$clause}{$name}{'impl'}
              or $inherited_impl{$name}) {
            $inherited_impl{$name}++;
            $spec->{$clause}{$name}{'impl'}=$parent->{$clause}{$name}{'impl'};
          }
          croak("Forget 'private'? $classname inherits private $name from ",
                "$ancestor\n")
            if ($parent->{$clause}{$name}{'private'}
                and not $spec->{$clause}{$name}{'private'})
        }
        # NOT IN PRODUCTION...
        # Inherit all post-conditions from ancestors
        if (@{$parent->{$clause}{$name}{'post'}||[]}) {
          my (@post, %seen) = (@{$spec->{$clause}{$name}{'post'}});
          if (@post) {
            $seen{$post[$_]} = $_  foreach (0..$#post);
            foreach my $item ( @{$parent->{$clause}{$name}{'post'}} ) {
              splice(@{$spec->{$clause}{$name}{'post'}}, $seen{$item}, 1)
                if exists $seen{$item};
            }
          }
          push(@{$spec->{$clause}{$name}{'post'}},
               @{$parent->{$clause}{$name}{'post'}});
        }
        # ...NOT IN PRODUCTION
      }
    }
    # NOT IN PRODUCTION...
    # Inherit all class invariants from ancestors
    if (defined $parent->{'invar'} and @{$parent->{'invar'}}) {
      defined $spec->{'invar'} or $spec->{'invar'} = [];
      my (@invar, %seen) = (@{$spec->{'invar'}});
      if (@invar) {
        $seen{$invar[$_]} = $_  foreach (0..$#invar);
        foreach (@{$parent->{'invar'}}) {
          splice(@{$spec->{'invar'}}, $seen{$_}, 1)  if exists $seen{$_}
        }
      }
      push @{$spec->{'invar'}}, @{$parent->{'invar'}};
    }
    # ...NOT IN PRODUCTION
  }

  no strict 'refs';
  unshift @{"${classname}::ISA"}, @{ $spec->{'parents'} || [] };
}

sub _attributes {
  my ($classname, $spec) = @_;

  while ( my ($name, $attr) = each %{$spec->{'attr'}} ) {
    if ($attr->{'shared'}) {
      my $ref = $class_attr{$classname}{$name} =
        $attr->{'type'} eq 'ARRAY'  ? []
      : $attr->{'type'} eq 'HASH'   ? {}
      : $attr->{'type'} eq 'SCALAR' ? do { \ my $scalar }
      : eval { $attr->{'type'}->new }
        || croak "Unable to create $attr->{'type'} object ",
                 "for class attribute $name";
    }

    localscope: {
      no strict 'refs';
      local $^W;
      *{"${classname}::$name"} = sub {
        croak(qq|Can\'t access object attr w/ class reference |,$attr->{'loc'})
          unless ($attr->{'shared'} or ref($_[0]));

        my $caller = caller;
        croak "attribute ${classname}::$name inaccessible from package $caller"
          unless $classname->isa($caller);

        my $self = shift;
        _set_context(($attr->{'shared'} ? ref($self)||$self : $self),
                     join ' line ', [caller]->[1,2]);
        my $attr_ref = ($attr->{'shared'})
          ? $class_attr{$classname}{$name}
          : $data{$$self}{$name};
        _set_value $attr_ref;

        # NOT IN PRODUCTION...
        my @fail = generic_check('pre', 'attr' => $name, $spec);
        croak @fail  if @fail;
        # ...NOT IN PRODUCTION

        _free_context;

        # NOT IN PRODUCTION...
        return "Class::Contract::Post$attr->{'gentype'}"->new(
          $attr->{'post'}, $attr_ref, $name,
        )  if @{$attr->{'post'}};
        # ...NOT IN PRODUCTION

        scalar _free_value;
        return $attr_ref;
      };
    }
  }
}

sub _methods {
  my ($classname, $spec) = @_;

  while ( my ($name, $method) = each %{$spec->{'method'}} ) {
    $spec->{'abstract'} ||= $method->{'abstract'};
    unless ($method->{'impl'}) {
      if ($method->{'abstract'}) {
        $method->{'impl'} = {'code' => sub {
          croak "Can't call abstract method ${classname}::$name"
        } }
      } else {
        croak qq{No implementation for method $name at $method->{'loc'}.\n},
        qq{(Did you forget to declare it 'abstract'?)\n}
      }
    }

    local_scope: {
      local $^W;
      no strict 'refs';
      *{"${classname}::$name"} = sub {
        my $caller = caller;
        croak("private method ${classname}::$name inaccessible from ",
              scalar caller)
          if ($method->{'private'}
              and not ($classname->isa($caller))); # or $caller->isa($classname)));

        my $self = shift;
        _set_context(($method->{'shared'} ? ref($self)||$self : $self),
                     join ' line ', [caller]->[1,2]);

        # NOT IN PRODUCTION...
        croak(qq|Can\'t invoke object method w/ class name |, $method->{'loc'})
          unless ($method->{'shared'} or ref($self));

        my $no_opt = no_opt($classname);
        my @fail = generic_check('pre', 'method' => $name, $spec, @_);
        croak @fail  if @fail;
        # ...NOT IN PRODUCTION

        _set_value wantarray
          ? $method->{'impl'}{'code'}->(@_)
          : scalar $method->{'impl'}{'code'}->(@_);

        # NOT IN PRODUCTION...
        generic_check('post',  'method' => $name, $spec, @_);
        generic_check('invar', 'method' => $name, $spec, @_)
          if (caller ne $classname);
        # ...NOT IN PRODUCTION

        _free_context;
        _free_value;
      };
    }
  }
}

# NOT IN PRODUCTION...
sub generic_check {
  return  if (ref(self)||self) =~ /^Class::Contract::Old::_/;

  my ($type, $kind, $name, $class_spec, @args) = @_;
  my @specs = @{$class_spec->{$kind}{$name}{$type}||[]};
  my @errors;

  foreach my $spec ( @specs ) {
    next  if $spec->{'opt'} && no_opt($spec->{'owner'})
      || $spec->{'code'}->(@args);
    push @errors, sprintf($spec->{'msg'},$spec->{'loc'})."\n";
  }

  @errors ? croak @errors : return   unless $type eq 'pre';
  return  if @specs && !@errors;

  # OTHERWISE SATISFY AT LEAST ONE PARENT?
  foreach my $ancestor ( @{$class_spec->{'parents'}||[]} ) {
    my $parent = $contract{$ancestor};
    next  unless exists $parent->{$kind}{$name};
    my $has_pre = scalar @{$parent->{$kind}{$name}{'pre'}};
    unless ($has_pre) {
      foreach my $p (@{$parent->{'parents'}||[]}) {
        $has_pre++ and last  if _hasa($p, $kind, $name, 'pre');
      }
    }

    if ($has_pre) {
      my @par_err = generic_check($type, $kind, $name, $parent, @args);
      return  unless @par_err;
      push @errors, @par_err;
    }
  }
  return @errors;
}

sub _hasa {
  my ($class, $kind, $name, $type) = (@_);
  return 0  unless defined $contract{$class}{$kind}{$name};

  my $has = @{$contract{$class}{$kind}{$name}{$type} || []} ? 1 : 0;
  unless ($has) {
    foreach my $ancestor (@{$contract{$class}{'parents'} || []}) {
      $has++ and last  if _hasa($ancestor, $kind, $name, $type);
    }
  }
  return $has;
}
# ...NOT IN PRODUCTION

sub generic_ctor {
  my ($class) = @_;

  croak "Class $class has abstract methods. Can't create $class object"
    if $contract{$class}{'abstract'};

  my $key = \ my $undef;
  my $obj = \ $key;
  bless $obj, $class;

  my $attr = $contract{$class}{'attr'};

  foreach my $attrname ( keys %$attr ) {
    unless ($attr->{$attrname} && $attr->{$attrname}{'shared'}) {
      my $ref = $data{$key}{$attrname}
      = $attr->{$attrname}{'type'} eq 'ARRAY'  ? []
      : $attr->{$attrname}{'type'} eq 'HASH'   ? {}
      : $attr->{$attrname}{'type'} eq 'SCALAR' ? do { \my $scalar }
      : eval { $attr->{$attrname}{type}->new }
      || croak "Unable to create $attr->{$attrname}{'type'} ",
               "object for attribute $attrname";
    }
  }

  return $obj;
}

sub generic_clone ($) {
  my $self = shift;
  my $ref = ref($self);
  croak "usage: \$object->clone -Invalid arg $self"
    unless ($ref and
            $ref !~ /^(HASH|ARRAY|SCALAR|GLOB|FORMAT|CODE|Regexp|REF)$/);
  my $key  = \ my $undef;
  my $obj  = bless \$key, $ref;
  $data{$key} = _dcopy($data{$$self})  if exists $data{$$self};
  return $obj;
}


sub _constructors {
  my ($classname, $spec) = @_;
  my $noctor = 1;

  while ( my ($name, $ctor) = each %{$spec->{'ctor'}} ) {
    $noctor &&= $ctor->{'shared'}
  }

  $spec->{'ctor'}{'new'} = bless {
    'name'     => 'new',
    'shared'   => 0,
    'abstract' => 0,
    'loc'      => ''
  }, 'Class::Contract::ctor'
    if $noctor;

  while ( my ($name, $ctor) = each %{$spec->{'ctor'}} ) {
    $spec->{'abstract'} ||= $ctor->{'abstract'};

    if ($ctor->{'shared'}) {
      localscope: {
        local $^W;
        no strict 'refs';
        my $classctor = sub {
          my $self = shift;
          _set_context ref($self)||$self;

          # NOT IN PRODUCTION...
          my @fail = generic_check('pre', 'ctor' => $name, $spec, @_);
          croak @fail  if @fail;
          # ...NOT IN PRODUCTION

          $_->{'code'}->(@_)  foreach ( @{$ctor->{'impl'}} );

          # NOT IN PRODUCTION...
          generic_check('post', 'ctor' => $name, $spec, @_);
          generic_check('invar','ctor' => $name, $spec, @_)
            if (caller ne $classname);
          # ...NOT IN PRODUCTION

          _free_context;
        };
        $classname->$classctor();
#        *{"${classname}::$name"} = $classctor  if $name;
      }
    } else {
      localscope:{
        local $^W;
        no strict 'refs';
        *{"${classname}::$name"} = sub {
          my $proto = shift;
          my $class = ref($proto)||$proto;
          my $self = Class::Contract::generic_ctor($class);
          _set_context $self;

          # NOT IN PRODUCTION...
          my @fail = generic_check('pre', 'ctor' => $name, $spec, @_);
          croak @fail  if @fail;
          # ...NOT IN PRODUCTION

          $_->{'code'}->(@_)  foreach ( @{$ctor->{'impl'}} );

          # NOT IN PRODUCTION...
          generic_check('post', 'ctor' => $name, $spec, @_);
          generic_check('invar','ctor' => $name, $spec, @_)
            if (caller ne $classname);
          # ...NOT IN PRODUCTION

          _free_context;
          return $self;
        }
      }
    }
  }
}

use Data::Dumper;
sub _destructors {

  my ($classname, $spec) = @_;
  my $dtorcount = 0;

  while ( my ($name, $dtor) = each %{$spec->{'dtor'}} ) {
    $spec->{'abstract'} ||= $dtor->{'abstract'};

    if ($dtor->{'shared'}) {
      localscope: {
        local $^W;
        no strict 'refs';
        my $classdtor = sub {
          croak "Illegal explicit invokation of class dtor", $dtor->{'loc'}
            if caller() ne 'Class::Contract';
          my $self = shift;
          $self = ref $self  if ref $self;

          _set_context $self;

          # NOT IN PRODUCTION...
          my @fail = generic_check('pre', 'dtor' => $name, $spec, @_);
          croak @fail  if @fail;
          # ...NOT IN PRODUCTION

          $_->{'code'}->(@_)  foreach ( @{$dtor->{'impl'}} );

          generic_check('post', 'dtor' => $name, $spec, @_);# NOT IN PRODUCTION
          _free_context;
        };

        push @class_dtors, sub { $classname->$classdtor() };
      }
    } else {
      croak "Class $classname has too many destructors"  if $dtorcount++;

      localscope: {
        local $^W;
        no strict 'refs';
        my $objdtor = sub {
          croak "Illegal explicit invokation of object dtor", $dtor->{'loc'}
            if caller() ne 'Class::Contract';

          my $self = shift;
          _set_context $self;

          # NOT IN PRODUCTION...
          my @fail = generic_check('pre', 'dtor' => $name, $spec, @_);
          croak @fail  if @fail;
          # ...NOT IN PRODUCTION

          $_->{'code'}->(@_)  foreach ( @{$dtor->{'impl'}||[]} );

          # NOT IN PRODUCTION...
          generic_check('post',  'dtor' => $name, $spec, @{[@_]});
          generic_check('invar', 'dtor' => $name, $spec, @{[@_]})
            if (caller ne $classname);
          # ...NOT IN PRODUCTION

          _free_context;
          return;
        };

        *{"${classname}::DESTROY"} = sub {
          $_[0]->$objdtor();
          delete $data{${$_[0]}}  if exists $data{${$_[0]}};
        };
      }
    }
  }
  unless (defined &{"${classname}::DESTROY"}) {
    local $^W;
    no strict 'refs';
    *{"${classname}::DESTROY"} = sub {
      delete $data{${$_[0]}}  if exists $data{${$_[0]}};
    };
  }
}

sub _clones {
  my ($classname, $spec) = @_;
  my $clone_count = 0;

  $spec->{'clone'}{''} = bless {
    'name'     => '',
    'shared'   => 0,
    'abstract' => 0,
    'loc'      => ''
  }, 'Class::Contract::clone'
    unless $spec->{'clone'};

  while ( my ($name, $clause) = each %{$spec->{'clone'}} ) {

    $spec->{'abstract'} ||= $clause->{'abstract'};
    croak "'class' clause can not be used to qualify 'clon'"
      if $clause->{'shared'};
    croak "too many clon clauses"  if $clone_count++;

    localscope: {
      local $^W;
      no strict 'refs';
      *{"${classname}::clone"} = sub {
        my $self = shift;
        $self = generic_clone($self);
        _set_context $self;

        # NOT IN PRODUCTION...
        my @fail = generic_check('pre', 'dtor' => $name, $spec, @_);
        croak @fail  if @fail;
        # ...NOT IN PRODUCTION

        $_->{'code'}->(@_)  foreach ( @{$clause->{'impl'}||[]} );

        # NOT IN PRODUCTION...
        generic_check('post',  $clause => $name, $spec, @{[@_]});
        generic_check('invar', $clause => $name, $spec, @{[@_]})
          if (caller ne $classname);
        # ...NOT IN PRODUCTION

        _free_context;
        return $self;
      };
    }
  }
}

localscope: {
  my ($a,$z) = (qr/(^|^.*?=)/, qr/\(.*?\)$/);
  my %seen = ();
  my $depth = 0;
  sub _dcopy { # Dereference and return a deep copy of whatever's passed
    my ($r, $ref, $rval);
    $ref = ref($_[0])   or return $_[0];
    exists $seen{$_[0]} and return $seen{$_[0]};
    $depth++;

    $r =
      ($_[0] =~ /${a}HASH$z/)   ? {map _dcopy($_), (%{$_[0]})}
    : ($_[0] =~ /${a}ARRAY$z/)  ? [map _dcopy($_), @{$_[0]} ]
    : ($_[0] =~ /${a}SCALAR$z/) ? do { my $v = _dcopy(${$_[0]}); \$v }
    : ($_[0] =~ /${a}FORMAT$z/) ? $_[0]
    : ($_[0] =~ /${a}CODE$z/)   ? $_[0]
    : ($_[0] =~ /${a}Regexp$z/) ? $_[0]
    : ($_[0] =~ /${a}REF$z/)    ? $_[0]
    : ($_[0] =~ /${a}GLOB$z/)   ? $_[0]
    : $_[0]->can('clone') ? $_[0]->clone : $_[0];

    $rval = $ref =~ /^(HASH|ARRAY|SCALAR|GLOB|FORMAT|CODE|Regexp|REF)$/
             ? $r
             : bless $r, $ref;

    --$depth
      and $seen{$_[0]} = $rval
      or  %seen = ();

    return $rval;
  }
}

# NOT IN PRODUCTION...
sub _pkg_copy ($$) { # $from_package, $to_package
  no strict 'refs';
  defined *{$_[0] . '::'}
    or croak "_pkg_copy() Can't clone from non-existant package $_[0]";
  defined *{$_[1] . '::'} and *{$_[1] . '::'} = {};

  foreach my $glob (values %{*{$_[0] . '::'}}) {
    my ($varname) = $glob =~ /^\*$_[0]::(.*)/ or next;
    foreach my $slot (qw(SCALAR ARRAY HASH CODE FORMAT)) {
      my $ref = _dcopy(*{"$_[0]::$varname"}{$slot});
      *{"$_[1]::$varname"} = $ref  if defined $ref;
    }
  }
}

sub _pkg_clear ($) {
  no strict 'refs';
  my ($package) = shift;
  my $stash = *{$package . '::'}{HASH};
  foreach my $name (keys %$stash) {
    $name = join('::', $package, $name);
#    print "undef $name\n";
    undef $$name;
    undef @$name;
    undef %$name;

    undef &$name;
    undef *$name;
  }
  undef %{$package . '::'};
}

sub Class::Contract::PostOBJECT::new {
  my ($class, $posts, $original, $name) = @_;
  my $objclass = ref $original;
  carp("Warning: cannot check post-condition",
       (@$posts==1?"":'s'),
       " on $objclass attribute '$name'")
    if $^W;
  _free_value;
  return $original;
}

package Class::Contract::PostSCALAR;

sub new {
  my $proxy;
  tie $proxy, 'Class::Contract::PostSCALAR', @_;
  return \$proxy;
}

sub TIESCALAR {
  my ($class, $self, $postsubs, $original) = @_;
  return bless {
    'orig' => $original,
    'post' => $postsubs,
  }, $class;
}

sub FETCH { return ${$_[0]->{'orig'}} }
sub STORE { ${$_[0]->{'orig'}} = $_[1] }

sub DESTROY {
  Class::Contract::generic_check('post', 'attr', @{self()}{qw(orig spec)}, @_);
  Class::Contract::_free_value();
}

package Class::Contract::PostARRAY;

sub new {
  my @proxy;
  tie @proxy, 'Class::Contract::PostARRAY', @_;
  if ($_[3]) { bless \@proxy, ref $_[2] }
  return \@proxy;
}

sub TIEARRAY {
  my ($class, $self, $postsubs, $original) = @_;
  return bless { 'orig' => $original,
     'post' => $postsubs,
         }, $class;
}

sub FETCH       { $_[0]->{'orig'}->[$_[1]] }
sub FETCHSIZE   { scalar @{$_[0]->{'orig'}} }
sub STORE       { $_[0]->{'orig'}->[$_[1]] = $_[2] }
sub STORESIZE   { $#{$_[0]->{'orig'}} = $_[1]-1 }
sub EXTEND      { $#{$_[0]->{'orig'}} = $_[1]-1 }
sub CLEAR       { @{$_[0]->{'orig'}} = () }
sub PUSH        { push @{$_[0]->{'orig'}}, @_[1..$#_] }
sub POP         { pop @{$_[0]->{'orig'}} }
sub UNSHIFT     { unshift @{$_[0]->{'orig'}}, @_[1..$#_] }
sub SHIFT       { shift @{$_[0]->{'orig'}} }

sub DESTROY {
  Class::Contract::generic_check('post', 'attr', @{self()}{qw(orig spec)}, @_);
  Class::Contract::_free_value();
}


package Class::Contract::PostHASH;

sub new {
  my %proxy;
  tie %proxy, 'Class::Contract::PostHASH', @_;
  if ($_[3]) { bless \%proxy, ref $_[2] }
  return \%proxy;
}

sub TIEHASH {
  my ($class, $self, $postsubs, $original) = @_;
  return bless { 'orig' => $original,
     'post' => $postsubs,
         }, $class;
}

sub FETCH       { $_[0]->{'orig'}->{$_[1]} }
sub STORE       { $_[0]->{'orig'}->{$_[1]} = $_[2] }
sub EXISTS      { exists $_[0]->{'orig'}->{$_[1]} }
sub DELETE      { delete $_[0]->{'orig'}->{$_[1]} }
sub CLEAR       { %{$_[0]->{'orig'}} = () }
sub FIRSTKEY    { keys %{$_[0]->{'orig'}}; each %{$_[0]->{'orig'}} }
sub NEXTKEY     { each %{$_[0]->{'orig'}} }

sub DESTROY {
  Class::Contract::generic_check('post', 'attr', @{self()}{qw(orig spec)}, @_);
  Class::Contract::_free_value();
}
# ...NOT IN PRODUCTION

1;

__END__